never executed always true always false

    1 {-# LANGUAGE DeriveDataTypeable #-}
    2 module Conjure.Language.AST.Reformer (HighLevelTree(..),HLTree(..),flatten,flattenSeq,contains,filterContaining,TreeItemLinks(..),ListItemClasses(..)) where
    3 
    4 import Conjure.Language.AST.Syntax
    5 import Conjure.Language.Lexer (ETok (..), trueStart, sourcePosAfter)
    6 import Conjure.Prelude
    7 
    8 
    9 import Data.Semigroup ((<>))
   10 import qualified Data.Sequence as S
   11 import Text.Megaparsec (SourcePos (SourcePos))
   12 
   13 
   14 
   15 
   16 -- class HighLevelTree a where
   17 --     makeTree :: HighLevelTree a => a -> S.Seq ETok
   18 flatten :: HighLevelTree a => a -> [ETok]
   19 flatten x = case makeTree x of
   20     HLNone -> []
   21     HLTagged _ xs -> concatMap flatten xs
   22     HLLeaf t -> [t]
   23 flattenSeq :: HighLevelTree a => a -> S.Seq ETok
   24 flattenSeq = S.fromList . flatten
   25 
   26 instance HighLevelTree HLTree where
   27     makeTree = id
   28 
   29 instance HighLevelTree StatementNode where
   30     makeTree x = case x of
   31         DeclarationStatement dsn -> makeTree dsn
   32         BranchingStatement bsn -> makeTree bsn
   33         SuchThatStatement stsn -> makeTree stsn
   34         WhereStatement wsn -> makeTree wsn
   35         ObjectiveStatement osn -> makeTree osn
   36         HeuristicStatement l1 ex -> makeTree l1 <> makeTree ex
   37         UnexpectedToken tok -> makeTree tok
   38 
   39 instance HighLevelTree DeclarationStatementNode where
   40     makeTree x = case x of
   41         FindStatement f fsn -> makeTree f <> makeTree fsn
   42         GivenStatement g gsn -> makeTree g <> makeTree gsn
   43         LettingStatement t lsn -> makeTree t <> makeTree lsn
   44 
   45 
   46 instance HighLevelTree LettingStatementNode where 
   47     makeTree (LettingStatementNode a b c) = mconcat[ makeTree a, makeTree b, makeTree c]
   48 
   49 instance HighLevelTree LettingAssignmentNode where
   50     makeTree x = case x of
   51         LettingExpr d ->  makeTree d
   52         LettingDomain d e -> makeTree d <> makeTree e
   53         LettingEnum d e f g -> mconcat [makeTree d, makeTree e, makeTree f, makeTree g]
   54         LettingUnnamed d e f g h -> mconcat [makeTree d, makeTree e, makeTree f, makeTree g, makeTree h]
   55 
   56 instance HighLevelTree FindStatementNode where
   57     makeTree (FindStatementNode a b c) = mconcat  [makeTree a, makeTree b, makeTree c]
   58 
   59 instance HighLevelTree GivenStatementNode where
   60     makeTree x = case x of
   61         GivenStatementNode a b c -> mconcat [makeTree a, makeTree b, makeTree c]
   62         GivenEnumNode a b c d -> mconcat [makeTree a, makeTree b, makeTree c, makeTree d]
   63 
   64 
   65 
   66 instance HighLevelTree BranchingStatementNode where
   67     makeTree (BranchingStatementNode lt lt' ln) = mconcat [makeTree lt, makeTree lt', makeTree ln]
   68 
   69 
   70 instance HighLevelTree SuchThatStatementNode where
   71     makeTree (SuchThatStatementNode l1 l2 l3) =  makeTree l1 <> makeTree l2 <> makeTree l3
   72 instance HighLevelTree WhereStatementNode where
   73     makeTree (WhereStatementNode l1 l2) =  makeTree l1 <> makeTree l2
   74 instance HighLevelTree ObjectiveStatementNode where
   75     makeTree x =  case x of
   76         ObjectiveMin lt en -> makeTree lt <> makeTree en
   77         ObjectiveMax lt en -> makeTree lt <> makeTree en
   78 
   79 
   80 
   81 
   82 instance HighLevelTree ExpressionNode where
   83     makeTree x = HLTagged (TIExpression x) $ case x of
   84         Literal ln -> [makeTree ln]
   85         IdentifierNode nn -> [makeTree nn]
   86         MetaVarExpr tk -> [makeTree tk]
   87         QuantificationExpr qen -> [makeTree qen]
   88         OperatorExpressionNode oen -> [makeTree oen]
   89         ParenExpression pen ->[makeTree pen]
   90         AbsExpression pen ->  [makeTree pen]
   91         DomainExpression dex -> [makeTree dex]
   92         FunctionalApplicationNode lt ln ->  [makeTree lt ,makeTree ln]
   93         SpecialCase nd -> [makeTree nd]
   94         AttributeAsConstriant l1 exprs -> [makeTree l1 , makeTree exprs]
   95         MissingExpressionNode e ->  [makeTree e]
   96 
   97 instance HighLevelTree SpecialCaseNode where 
   98     makeTree x = case x of 
   99         ExprWithDecls l1 en l2 sns l3 -> mconcat [makeTree l1,makeTree en,makeTree l2, makeTree sns , makeTree l3]
  100 
  101 
  102 instance HighLevelTree DomainExpressionNode where
  103     makeTree (DomainExpressionNode a b c) = makeTree a <> makeTree b <> makeTree c
  104 instance HighLevelTree QuantificationExpressionNode where
  105     makeTree (QuantificationExpressionNode a b c d e f) = mconcat [
  106         makeTree a, makeTree b, makeTree c, makeTree d, makeTree e, makeTree f]
  107 
  108 instance HighLevelTree QuantificationOverNode where
  109     makeTree x = case x of
  110       QuantifiedSubsetOfNode a b -> makeTree a <> makeTree b
  111       QuantifiedMemberOfNode a b -> makeTree a <> makeTree b
  112       QuantifiedDomainNode a -> makeTree a
  113 
  114 instance HighLevelTree OverDomainNode where
  115     makeTree (OverDomainNode a b) = makeTree a <> makeTree b
  116 
  117 instance HighLevelTree QuanticationGuard where
  118     makeTree (QuanticationGuard a b ) = makeTree a <> makeTree b
  119 
  120 instance HighLevelTree AbstractPatternNode where
  121     makeTree x = case x of
  122       AbstractIdentifier nn -> makeTree nn
  123       AbstractMetaVar lt -> makeTree lt
  124       AbstractPatternTuple a b -> makeTree a <> makeTree b
  125       AbstractPatternMatrix ln -> makeTree ln
  126       AbstractPatternSet ln -> makeTree ln
  127 instance HighLevelTree QuantificationPattern where
  128     makeTree (QuantificationPattern en) = makeTree en
  129 
  130 instance HighLevelTree LiteralNode where
  131     makeTree x = case x of
  132         IntLiteral lt Nothing -> makeTree lt
  133         IntLiteral lt (Just (cln, tag)) -> makeTree lt <> makeTree cln <> makeTree tag
  134         BoolLiteral lt -> makeTree lt
  135         MatrixLiteral mln -> makeTree mln
  136         TupleLiteralNode lt -> makeTree lt
  137         TupleLiteralNodeShort st -> makeTree st
  138         RecordLiteral lt ln -> makeTree lt <> makeTree ln
  139         VariantLiteral lt ln -> makeTree lt <> makeTree ln
  140         SetLiteral ln -> makeTree ln
  141         MSetLiteral lt ln -> makeTree lt <> makeTree ln
  142         FunctionLiteral lt ln -> makeTree lt <> makeTree ln
  143         SequenceLiteral lt ln -> makeTree lt <> makeTree ln
  144         PermutationLiteral lt ln -> makeTree lt <> makeTree ln
  145         RelationLiteral lt ln -> makeTree lt <> makeTree ln
  146         PartitionLiteral lt ln -> makeTree lt <> makeTree ln
  147 
  148 instance HighLevelTree ETok where
  149     makeTree = HLLeaf
  150 
  151 instance HighLevelTree PermutationElemNode where
  152     makeTree (PermutationElemNode ln) = makeTree ln
  153 
  154 instance HighLevelTree PartitionElemNode where
  155     makeTree (PartitionElemNode ln) = makeTree ln
  156 
  157 instance HighLevelTree RelationElemNode where
  158     makeTree x = case x of
  159         RelationElemNodeLabeled lt -> makeTree lt
  160         RelationElemNodeShort st -> makeTree st
  161 
  162 instance HighLevelTree ArrowPairNode where
  163     makeTree (ArrowPairNode a b c) = mconcat [makeTree a, makeTree b, makeTree c]
  164 
  165 instance HighLevelTree RecordMemberNode where
  166     makeTree (RecordMemberNode nn lt en) =  mconcat [makeTree nn, makeTree lt, makeTree en]
  167 instance HighLevelTree LongTuple where
  168     makeTree (LongTuple a b) =  makeTree a <> makeTree b
  169 
  170 instance HighLevelTree ShortTuple where
  171     makeTree (ShortTuple a) = makeTree a
  172 
  173 instance HighLevelTree MatrixLiteralNode where
  174     makeTree ( MatrixLiteralNode a b c d e) = mconcat
  175             [ makeTree a
  176             , makeTree b
  177             , makeTree c
  178             , makeTree d
  179             , makeTree e
  180             ]
  181 
  182 instance HighLevelTree ComprehensionNode where
  183     makeTree (ComprehensionNode a b) = makeTree a <> makeTree b
  184 instance HighLevelTree ComprehensionExpressionNode where
  185     makeTree (ComprehensionExpressionNode a b c d e) =
  186         mconcat
  187             [ makeTree a
  188             , makeTree b
  189             , makeTree c
  190             , makeTree d
  191             , makeTree e
  192             ]
  193 
  194 instance HighLevelTree ComprehensionBodyNode where
  195     makeTree x =  case x of
  196         CompBodyCondition en -> makeTree en
  197         CompBodyDomain a b c -> makeTree a <> makeTree b <> makeTree c
  198         CompBodyGenExpr a b c -> makeTree a <> makeTree b <> makeTree c
  199         CompBodyLettingNode a b c d -> mconcat [makeTree a, makeTree b, makeTree c, makeTree d]
  200 
  201 instance HighLevelTree OperatorExpressionNode where
  202     makeTree x =  case x of
  203         PostfixOpNode en pon -> makeTree en <> makeTree pon
  204         PrefixOpNode lt en -> makeTree lt <> makeTree en
  205         BinaryOpNode en lt en' -> mconcat [makeTree en, makeTree lt, makeTree en']
  206 
  207 instance HighLevelTree PostfixOpNode where
  208     makeTree x =  case x of
  209         IndexedNode l -> makeTree l
  210         OpFactorial lt -> makeTree lt
  211         ApplicationNode ln -> makeTree ln
  212         ExplicitDomain l1 l2 dom l3 -> mconcat  [makeTree l1,makeTree l2,makeTree dom,makeTree l3]
  213 
  214 
  215 
  216 
  217 instance HighLevelTree DomainNode where
  218     makeTree x = HLTagged (TIDomain x) $ case x of
  219         ParenDomainNode a b c -> [makeTree a, makeTree b, makeTree c]
  220         BoolDomainNode lt -> [makeTree lt]
  221         RangedIntDomainNode lt Nothing ln -> [makeTree lt, makeTree ln]
  222         RangedIntDomainNode lt (Just (cln, tag)) ln -> [makeTree lt, makeTree cln, makeTree tag, makeTree ln]
  223         MetaVarDomain a -> [makeTree a]
  224         RangedEnumNode nn ln -> [makeTree nn ,  makeTree ln]
  225         -- EnumDomainNode nn -> makeTree nn
  226         ShortTupleDomainNode ln -> [makeTree ln]
  227         TupleDomainNode lt ln -> [makeTree lt , makeTree ln]
  228         RecordDomainNode lt ln -> [makeTree lt , makeTree ln]
  229         VariantDomainNode lt ln -> [makeTree lt , makeTree ln]
  230         MatrixDomainNode a m_ib b c d -> [makeTree a ,makeTree m_ib, makeTree b , makeTree c , makeTree d]
  231         SetDomainNode a b c d -> [makeTree a , makeTree  b , makeTree c , makeTree d]
  232         MSetDomainNode a b c d -> [makeTree a , makeTree  b, makeTree c , makeTree d]
  233         FunctionDomainNode a b c d e -> [makeTree a , makeTree  b , makeTree c , makeTree d,makeTree e]
  234         SequenceDomainNode a b c d -> [makeTree a , makeTree  b , makeTree c , makeTree d]
  235         PermutationDomainNode a b c d -> [makeTree a , makeTree  b , makeTree c , makeTree d]
  236         RelationDomainNode a b c d -> [makeTree a , makeTree b , makeTree c , makeTree d]
  237         PartitionDomainNode a b c d -> [makeTree a , makeTree b , makeTree c , makeTree d]
  238         MissingDomainNode m -> [makeTree m]
  239 
  240 instance HighLevelTree IndexedByNode where
  241     makeTree (IndexedByNode a b ) = makeTree a <> makeTree b
  242 
  243 
  244 instance HighLevelTree a => HighLevelTree (Maybe a) where
  245   makeTree = maybe mempty makeTree 
  246 
  247 instance HighLevelTree AttributeNode where
  248     makeTree x =  case x of
  249         NamedAttributeNode nn m_e -> makeTree nn <> makeTree m_e
  250         -- NamedExpressionAttribute nn en -> makeTree nn <> makeTree en
  251 
  252 instance HighLevelTree RangeNode where
  253     makeTree x =  case x of
  254         SingleRangeNode en -> makeTree en
  255         OpenRangeNode ddn -> makeTree ddn
  256         RightUnboundedRangeNode en ddn -> makeTree en <> makeTree ddn
  257         LeftUnboundedRangeNode ddn en -> makeTree ddn <> makeTree en
  258         BoundedRangeNode en ddn en' -> mconcat [makeTree en, makeTree ddn, makeTree en']
  259 
  260 -- instance HighLevelTree DoubleDotNode where
  261 --     makeTree (DoubleDotNode a b) =  makeTree a <> makeTree b
  262 
  263 instance HighLevelTree NamedDomainNode where
  264     makeTree (NameDomainNode a Nothing) = makeTree a
  265     makeTree (NameDomainNode a (Just (b,c))) = mconcat [makeTree a,makeTree b,makeTree c]
  266 
  267 instance HighLevelTree NameNode where
  268     makeTree (NameNode n) =  makeTree n
  269     makeTree (MissingNameNode n) =  makeTree n
  270 
  271 instance HighLevelTree NameNodeS where
  272     makeTree (NameNodeS n) =  makeTree n
  273 instance HighLevelTree ParenExpressionNode where
  274     makeTree (ParenExpressionNode a b c) =  makeTree a <> makeTree b <> makeTree c
  275 
  276 
  277 
  278 
  279 
  280 instance HighLevelTree b => HighLevelTree (Sequence b) where
  281     makeTree (Seq es) = mconcat $ map makeTree es
  282 
  283 instance HighLevelTree b => HighLevelTree (SeqElem b) where
  284     makeTree (SeqElem v s) =  makeTree v <> makeTree s
  285     makeTree (MissingSeqElem v s) =  makeTree v <> makeTree s
  286 instance HighLevelTree b => HighLevelTree [b] where
  287     makeTree = HLTagged TIGeneral . map makeTree 
  288 
  289 type TreeTag = ListItemClasses
  290 data HLTree 
  291     = HLTagged TreeItemLinks [HLTree]
  292     | HLLeaf ETok
  293     | HLNone
  294     deriving (Show,Data,Typeable)
  295 
  296 instance Semigroup HLTree where
  297     HLNone <> a = a
  298     a <> HLNone = a
  299     HLTagged TIGeneral xs <> a = HLTagged TIGeneral (xs++[a])
  300     a <> HLTagged TIGeneral xs = HLTagged TIGeneral $ a:xs
  301     a <> b = HLTagged TIGeneral [a,b]
  302 
  303 instance Monoid HLTree where
  304     mempty = HLNone
  305 
  306 taggedSeq :: HighLevelTree a => TreeTag -> Sequence a -> HLTree
  307 taggedSeq s (Seq els) = HLTagged (TIList s) $ makeTree <$> els 
  308 taggedList :: HighLevelTree a => TreeTag -> ListNode a -> HLTree
  309 taggedList s (ListNode a b c) = HLTagged TIGeneral $ makeTree a : taggedSeq s b  : [makeTree c]
  310 
  311 -- Tag types for nodes, mainly used to guide completions
  312 data ListItemClasses 
  313     = ICAttribute
  314     | ICExpression
  315     | ICDomain
  316     | ICRange
  317     | ICIdentifier
  318     | ICStatement
  319     deriving (Show,Data,Ord,Eq)
  320 
  321 -- Embed the actual syntax portion into the tree, in case needed
  322 data TreeItemLinks
  323     = TIExpression ExpressionNode
  324     | TIDomain DomainNode
  325     | TIList ListItemClasses
  326     | TIGeneral
  327     deriving (Show,Data)
  328 instance Eq TreeItemLinks where
  329     TIGeneral == TIGeneral = True
  330     _ == _ = False
  331 instance HighLevelTree (ListNode ExpressionNode) where
  332     makeTree = taggedList ICExpression
  333 instance HighLevelTree (ListNode NameNode) where
  334     makeTree = taggedList ICIdentifier
  335 instance HighLevelTree (ListNode DomainNode) where
  336     makeTree = taggedList ICDomain
  337 
  338 instance HighLevelTree (ListNode RangeNode) where
  339     makeTree = taggedList ICRange
  340 
  341 instance HighLevelTree (ListNode AttributeNode) where
  342     makeTree = taggedList ICAttribute
  343 instance HighLevelTree (ListNode RecordMemberNode) where
  344     makeTree = taggedList ICIdentifier
  345 instance HighLevelTree (ListNode ArrowPairNode) where
  346     makeTree = taggedList ICIdentifier
  347 instance HighLevelTree (ListNode RelationElemNode) where
  348     makeTree = taggedList ICIdentifier
  349 instance HighLevelTree (ListNode PermutationElemNode) where
  350     makeTree = taggedList ICIdentifier
  351 instance HighLevelTree (ListNode PartitionElemNode) where
  352     makeTree = taggedList ICIdentifier
  353 instance HighLevelTree (ListNode NamedDomainNode) where
  354     makeTree = taggedList ICIdentifier
  355 
  356 instance HighLevelTree (ListNode AbstractPatternNode) where
  357     makeTree = taggedList ICIdentifier
  358 class HighLevelTree a where
  359     makeTree :: a -> HLTree
  360 
  361 instance HighLevelTree LToken where
  362     makeTree (RealToken a) = makeTree a
  363     makeTree (SkippedToken t) = HLLeaf t
  364     makeTree (MissingToken m) = HLLeaf m
  365 instance HighLevelTree SToken where
  366     makeTree (StrictToken ts t) =  HLTagged TIGeneral $ (HLLeaf <$> ts) ++ [HLLeaf t] 
  367 
  368 instance HighLevelTree ProgramTree where
  369   makeTree (ProgramTree Nothing sts cln) = HLTagged TIGeneral $ (HLTagged (TIList ICStatement) $ makeTree <$> sts) : [makeTree cln] 
  370   makeTree (ProgramTree (Just lv) sts cln) = HLTagged TIGeneral $ [makeTree lv] ++ (makeTree <$> sts) ++ [makeTree cln] 
  371 
  372 instance HighLevelTree LangVersionNode where
  373     makeTree (LangVersionNode a b c) = HLTagged TIGeneral $ makeTree a : makeTree b : [makeTree c]
  374 
  375 
  376 -- getContainers :: HLTree -> Int -> Int -> HLTree
  377 -- getContainers HLNone r c = HLNone
  378 
  379 
  380 bounds :: ETok -> SourcePos -> Bool
  381 bounds t (SourcePos _ r c)= let
  382     (SourcePos _ rl cl,SourcePos _ rr cr) = (trueStart t,sourcePosAfter  t)
  383         in r >= rl && c >= cl && r <= rr && c <= cr
  384 
  385 -- inBounds :: SourcePos -> HLTree -> Bool
  386 -- inBounds (SourcePos _ r c) t 
  387 --     | null $ flatten t = False
  388 --     | otherwise = let 
  389 --         (SourcePos _ rl cl,SourcePos _ rr cr) = bounds t
  390 --         in r >= rl && c >= cl && r <= rr && c <= cr
  391 
  392 contains :: SourcePos -> HLTree -> Bool
  393 contains p t = case t of 
  394     HLNone -> False
  395     HLLeaf e -> bounds e p
  396     HLTagged _ xs -> any (contains p) xs
  397     -- HLGeneral xs -> any (contains p) xs
  398     -- HLList _ xs -> any (contains p ) xs
  399 
  400 filterContaining :: SourcePos -> HLTree -> [HLTree]
  401 filterContaining _ HLNone = []
  402 filterContaining p n@(HLLeaf _) = [n |contains p n]
  403 filterContaining p (HLTagged t xs) = let cs = [x | x <-xs,contains p x]
  404                                         in HLTagged t cs : concatMap (filterContaining p) cs