imports { import CommonTypes import PresLayerTypes import PresLayerUtils import XprezLib import XLatex hiding (bold) import DocumentEdit import List import Data.FiniteMap import IOExts import qualified Chess --import EvaluateTypes -- for OU demo --import qualified UHA_Pretty (sem_Expression) -- for OU demo import DocTypes (DocumentLevel (..)) import DocTypes_Generated import DocUtils_Generated import DocumentEdit_Generated } INCLUDE "PresentationAG_Generated.ag" INCLUDE "LambdaReduce.ag" INCLUDE "InvPresentation.ag" {- TODO: fix loc and path for case and let exps -- lists and pres/press ParseErr, etc is unclear still. When to insert structurals/parsing nodes? -- parsing/structural nodes should be inserted above holes and parse errors as well! -- otherwise recognition/gatherchildren misses children -- prims should be boxed, otherwise there are too many special cases -- need control over structural navigation! focus on invisible elements, or Ident instead of IdentExp -- is not good. Important: When defining new attributes on Exp, take care that the (,,,,) patterns at LamExp.val and LetExp.val in the evaluator AG are updated as well. Both mimic higher order ag behavior by calling the semExp function. Xprez problem, background color on row with one StringP element does not work. Temporary workaround, add StringP _ "" to row -} -------------------------------------------------------------- -- -- Parse errors -- -------------------------------------------------------------- SEM List_Decl [ | | parseErrs : {[String]} ] | ParseErrList_Decl lhs.parseErrs = [] --- NOT RIGHT! | HoleList_Decl lhs.parseErrs = [] SEM ConsList_Decl [ | | parseErrs : {[String]} ] | Cons_Decl lhs.parseErrs = [] | Nil_Decl lhs.parseErrs = [] -------------------------------------------------------------- -- -- Document Presentation -- -------------------------------------------------------------- ATTR List_Decl ConsList_Decl Decl Exp List_Exp ConsList_Exp List_Alt ConsList_Alt Alt -- don't want to put these in Exp and Exps, but otherwise we have -- to define them at LetExp's [ errs : {[HeliumMessage]} topLevelEnv : {[(String, String)]} typeEnv : {[(PathDoc,String)]} | | ] ATTR List_Decl ConsList_Decl Decl Ident Exp List_Exp ConsList_Exp List_Alt ConsList_Alt Alt [ ranges : {([PathDoc],[PathDoc],[PathDoc])} | | ] ATTR List_Decl ConsList_Decl Decl Ident Exp List_Exp ConsList_Exp List_Alt ConsList_Alt Alt [ level : Int | | ] -- level of declarations 0 = top SEM EnrichedDoc | RootEnr decls.level = 0 loc.errs = let (errs, typeEnv, topLevelEnv) = @heliumTypeInfo in errs loc.typeEnv = let (errs, typeEnv, topLevelEnv) = @heliumTypeInfo in topLevelEnv loc.topLevelEnv = let (errs, typeEnv, topLevelEnv) = @heliumTypeInfo in typeEnv SEM Exp | LetExp decls.level = @lhs.level + 1 SEM EnrichedDoc | RootEnr lhs.pres = loc (RootDocNode @document []) $ --HACK!! top level loc needs to be a ref to the document -- it is used by mkPopupMenuXY in Renderer. -- A better implementation of popups will create the menu in -- the higher layers. Although it is still a bit unclear where loc (RootEnrNode @self []) $ structural $ col [ row' [ hSpace 3 -- , text $ "Document focus: " ++show @lhs.focusD , text "Focused expression" `withFontFam` "verdana" -- ++show @lhs.focusD , typeD NoIDP $ ( case lookup @lhs.focusD @typeEnv of Nothing -> "" Just tp -> " :: "++tp) ++ replicate 80 ' ' -- so hline stretches beyond longest line ] `withFontSize` 10 , row' [ hSpace 3 , row[ text "Top level identifiers: " `withFontFam` "verdana", @idListDecls.idsPres] `withFontSize` 10 -- , row[ text "Top level identifiers disabled" `withFontFam` "verdana"] `withFontSize` 10 ] , vSpace 4 --, myTree , hLine , vSpace 4 -- tree & XML --, structural $ empty -- row [ hSpace 3, box $ row [ hSpace 3, @decls.presTree, text " "{-, vLine , text " ", @decls.presXML `withFont'` ("Courier New",8), hSpace 3-}]] --, vSpace 14 -- end tree & XML , row' [ hSpace 3, key NoIDP "module ", bold $ text "Main" , key NoIDP " where"] , row' [ hSpace 3, @decls.pres ] , vSpace 10 , hLine , vSpace 4 -- empty col's are buggy in Xprez , let errs = if null @decls.parseErrs then @errs else map toMessage @decls.parseErrs in col' (map presMessage errs ++ [empty]) `withFontSize` 12 , vSpace 10 , hLine , vSpace 4 , text "Variables in scope:" `withFont'` ("verdana",10) , col [ typeD NoIDP (var++" :: "++tpStr) `link` pth | (var,(pth,tpStr)) <- fmToList @decls.varsInScopeAtFocus ] ] `withFont'` ("Courier New",14) decls.ranges = (\(l1,l2,l3)->(concat l1, concat l2, concat l3)) . unzip3 $ map pthFrmMsg @errs { pthFrmMsg :: HeliumMessage -> ([PathDoc], [PathDoc], [PathDoc]) pthFrmMsg (HError _ ps1 ps2 ps3) = (ps1, ps2, ps3) pthFrmMsg _ = ([],[],[]) toMessage str = HError (lines str) [] [] [] -- if ps1 ++ ps2 ++ ps3 not null then head is link presMessage :: HeliumMessage -> Presentation doc Node clip presMessage (HError lns ps1 ps2 ps3) = case ps1++ps2++ps3 of [] -> col' (map (text) lns) `withColor` errColor rng:_ -> col' (map (text) lns) `withColor` errColor `link` rng presMessage (HMessage lns) = col' (map (text) lns) `withColor` msgColor msgColor = blue errColor = red } SEM List_Decl [ || pres : Presentation_Doc_Node_Clip ] | List_Decl lhs.pres = loc (List_DeclNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ row @elts.press | ParseErrList_Decl lhs.pres = loc (List_DeclNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ presParseErr @node @presentation | HoleList_Decl lhs.pres = loc (List_DeclNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ presHole @lhs.focusD "Decls" (HoleList_DeclNode @self @lhs.path) @lhs.path {- SEM List_Decl | List_Decl lhs.idsPres = loc (List_DeclNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ @elts.idsPres | HoleList_Decl lhs.idsPres = presHole @lhs.focusD "Decls" (List_DeclNode @self @lhs.path) @lhs.path | ParseErrList_Decl lhs.idsPres = empty -- must be empty, otherwise initDoc hack fails -} SEM Decl | Decl lhs.pres = loc (DeclNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ (row' $ (if @lhs.level == 0 then let sigIDP = mkIDP @idP2 @lhs.pIdC 2 autoLStr = if @autoLayout.bool then " {auto layout}" else "" in case @typeStr of Nothing -> case @exp.val of ErrVal -> [ StructuralP sigIDP $ row' -- this structural has no loc, since the value is not in the tree [text ("-- No value"++autoLStr)] `withbgColor` commentCol -- row is for backgr.] ] v -> [ StructuralP sigIDP $ row' [text ("-- Value: " ++ show @exp.val++autoLStr )] `withbgColor` commentCol -- row is for backgr. ] Just tpstr -> -- this structural has no loc, since the type and value are not in the tree [ StructuralP sigIDP . row' $ [ typeD NoIDP (tpstr) , text " " , case @exp.val of ErrVal -> row' [text ("-- No value"++autoLStr)] `withbgColor` commentCol -- row is for backgr.] v -> row' [ text ("-- Value: " ++ show @exp.val++autoLStr)] `withbgColor` commentCol -- row is for backgr. ] ] else [empty]) ++ [ @ident.pres, key (mkIDP @idP0 @lhs.pIdC 0) "="] ++ (if @expanded.bool then [ @exp.pres, sep (mkIDP @idP1 @lhs.pIdC 1) ";" ] else [text " ", box (text "...") `withColor` black `withbgColor` yellow `withMouseDown` expand @lhs.path @self]) ) `addPopupItems` [ if @expanded.bool then ( "Collapse: "++strFromIdent @ident.self, toggleExpanded @lhs.path @self) else ( "Expand: "++strFromIdent @ident.self, toggleExpanded @lhs.path @self)] `addPopupItems` if @lhs.level == 0 then [ if @autoLayout.bool then ( "Disable Auto Layout", toggleAutoLayout @lhs.path @self) else ( "Enable Auto Layout", toggleAutoLayout @lhs.path @self) ] else [] SEM Ident | Ident lhs.pres = loc (IdentNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ row' [ text' (mkIDP @idP0 @lhs.pIdC 0) "", @string_.pres, text ""] -- somehow we have to put the ident idp in the string pres {- each exp has a local @reductionEdit attribute that defines popup items for possible reduction edit operations. The items are added to the presentation with: addReductionPopupItems @reductionEdit and are defined in "LambdaReduce.ag" -} SEM Exp | PlusExp lhs.pres = loc (PlusExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' [@exp1.pres , op (mkIDP @idP0 @lhs.pIdC 0) "+", @exp2.pres] | TimesExp lhs.pres = loc (TimesExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' [@exp1.pres , op (mkIDP @idP0 @lhs.pIdC 0) "*", @exp2.pres] | DivExp lhs.pres = loc (DivExpNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ frac @exp1.pres @exp2.pres | PowerExp lhs.pres = loc (PowerExpNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ power @exp1.pres @exp2.pres | BoolExp -- put the idP in an empty string before the bool presentation lhs.pres = loc (BoolExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' [cons (mkIDP @idP0 @lhs.pIdC 0) "", @bool_.pres] | IntExp -- put the idP in an empty string before the int presentation lhs.pres = loc (IntExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' [cons (mkIDP @idP0 @lhs.pIdC 0) "", @int_.pres] | LamExp lhs.pres = loc (LamExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' [ key (mkIDP @idP0 @lhs.pIdC 0) "\\" -- text' (mkIDP @idP0 @lhs.pIdC 0) "" -- trick because "symbol" spaces have wrong width -- **Screenshot** -- , key NoIDP "l" `withFontFam` "symbol" -- **Screenshot** , @ident.pres -- **Screenshot** , text' (mkIDP @idP1 @lhs.pIdC 1) "" -- trick because "symbol" spaces have wrong width , key NoIDP "\174" `withFontFam` "symbol" -- , key (mkIDP @idP1 @lhs.pIdC 1) "->" , @exp.pres ] | AppExp lhs.pres = loc (AppExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' [@exp1.pres, @exp2.pres] | CaseExp lhs.pres = loc (CaseExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' [ key (mkIDP @idP0 @lhs.pIdC 0) "case" , @exp.pres , key (mkIDP @idP1 @lhs.pIdC 1) "of" , loc (List_AltNode @alts.self [] {- @alts.path-}) $ parsing $ presentFocus @lhs.focusD [] {-@alts.path-} $ row @alts.press ] | LetExp lhs.pres = loc (CaseExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' [ key (mkIDP @idP0 @lhs.pIdC 0) "let" , loc (List_DeclNode @decls.self []{-@decls.path-}) $ parsing $ presentFocus @lhs.focusD [] {-@decls.path-} $ row @decls.press , key (mkIDP @idP1 @lhs.pIdC 1) "in", @exp.pres ] | IdentExp lhs.pres = loc (IdentExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ @ident.pres `addPopupItems` [( "Jump to declaration of "++show (strFromIdent @ident.self), navigateTo $ case lookupFM @lhs.varsInScope (strFromIdent @ident.self) of Nothing -> NoPathD Just (pth,_) -> pth)] | IfExp lhs.pres = loc (IfExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' $ [ key (mkIDP @idP0 @lhs.pIdC 0) "if", @exp1.pres , key (mkIDP @idP1 @lhs.pIdC 1) "then", @exp2.pres , key (mkIDP @idP2 @lhs.pIdC 2) "else", @exp3.pres ] | ParenExp lhs.pres = loc (ParenExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' [sep (mkIDP @idP0 @lhs.pIdC 0) "(", @exp.pres , sep (mkIDP @idP1 @lhs.pIdC 1) ")"] | ListExp lhs.pres = loc (ListExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' $ [sep (mkIDP @idP0 @lhs.pIdC 0) "["] ++ let xps = @exps.press sps = map (\id -> sep id ",") (@ids++ map IDP [@lhs.pIdC .. ] ) in (if null xps then [] else head xps : concat [ [s,e] | (s,e) <- zip sps (tail xps)]) ++ [sep (mkIDP @idP1 @lhs.pIdC 1) "]"] | ProductExp lhs.pres = loc (ProductExpNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row' $ [sep (mkIDP @idP0 @lhs.pIdC 0) "("] ++ let xps = @exps.press sps = map (\id -> sep id ",") (@ids++ map IDP [@lhs.pIdC .. ] ) in if null xps then [] else head xps : concat [ [s,e] | (s,e) <- zip sps (tail xps)] ++ [sep (mkIDP @idP1 @lhs.pIdC 1) ")"] SEM Alt | Alt lhs.pres = loc (AltNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ squiggleRanges @lhs.ranges @lhs.path $ row' $ [ @ident.pres -- , key (mkIDP @idP0 @lhs.pIdC 0) "->" , text' (mkIDP @idP0 @lhs.pIdC 0) "", key NoIDP "\174" `withFontFam` "symbol" , @exp.pres , sep (mkIDP @idP1 @lhs.pIdC 1) ";" ] { presentFocus NoPathD path pres = pres presentFocus (PathD pth) path pres = if pth==path then pres `withbgColor` focusCol else pres squiggleRanges (rngs1, rngs2, rngs3) pth pres = if (PathD pth) `elem` rngs1 then squiggly error1Color pres else if (PathD pth) `elem` rngs2 then pres -- squiggly error2Color pres else if (PathD pth) `elem` rngs3 then squiggly error3Color pres else pres -- WX bitmap coloring is not ok yet, so squigglies are always red. -- Until this is fixed, green squigglies are not shown error1Color = red error2Color = green error3Color = red link :: Xprez doc node clip -> PathDoc -> Xprez doc node clip link xp NoPathD = xp link xp path = xp `withMouseDown` navigateTo path navigateTo :: PathDoc -> UpdateDoc doc clip navigateTo NoPathD = id navigateTo (PathD pth) = (\(DocumentLevel d _ cl) -> DocumentLevel d (PathD pth) cl) expand :: [Int] -> Decl -> UpdateDoc Document clip expand pth (Decl idD idP0 idP1 idP2 idP3 expanded autoLayout ident exp) = \(DocumentLevel d path cl) -> let (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD pth) (Clip_Decl (Decl idD idP0 idP1 idP2 idP3 (Bool_ NoIDD True) autoLayout ident exp)) ) in (DocumentLevel d' path cl) toggleExpanded :: [Int] -> Decl -> UpdateDoc Document clip toggleExpanded pth (Decl idD idP0 idP1 idP2 idP3 expanded autoLayout ident exp) = \(DocumentLevel d path cl) -> let (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD pth) (Clip_Decl (Decl idD idP0 idP1 idP2 idP3 (Bool_ NoIDD (not $ boolVal expanded)) autoLayout ident exp)) ) in (DocumentLevel d' path cl) toggleAutoLayout :: [Int] -> Decl -> UpdateDoc Document clip toggleAutoLayout pth (Decl idD idP0 idP1 idP2 idP3 expanded autoLayout ident exp) = \(DocumentLevel d path cl) -> let (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD pth) (Clip_Decl (Decl idD idP0 idP1 idP2 idP3 expanded (Bool_ NoIDD (not $ boolVal autoLayout)) ident exp)) ) in (DocumentLevel d' path cl) -- use attributes! strFromIdent (Ident _ _ _ (String_ _ str)) = str strFromIdent _ = "" idP0FromIdent (Ident _ idp0 _ str) = idp0 idP0FromIdent _ = NoIDP box xp = overlay [xp, poly [(0,0),(1,0),(1,1),(0,1),(0,0)],empty] presHole focus typeStr nd pth = loc nd $ structural $ row [text $ "{"++typeStr++"}"] `withColor` black `withbgColor` yellow `withFontFam` ("Courier New") -- structural $ overlay [poly [(0,0),(1,0),(1,1),(0,1),(0,0)], text $ "{"++typeStr++"}"] `withColor` black `withbgColor` yellow `withFont'` ("Courier New", 10) presParseErr node pres = loc node $ parsing $ pres {- $ overlay [ pres, poly [(0,0),(1,0),(1,1),(0,1),(0,0)] `withColor` red, empty ] -} -- empty trick `withbgColor` whiteSmoke row' = RowP (NoIDP) 0 col' = ColP (NoIDP) 0 text' idc = StringP idc der:: IDP -> String -> Xprez doc node clip der idc str = StringP idc str `withColor` derCol op :: IDP -> String -> Xprez doc node clip op idc str = StringP idc str `withColor` opCol key :: IDP -> String -> Xprez doc node clip key idc str = StringP idc str `withColor` keyCol sep :: IDP -> String -> Xprez doc node clip sep idc str = StringP idc str `withColor` sepCol cons :: IDP -> String -> Xprez doc node clip cons idc str = StringP idc str `withColor` consCol typeD :: IDP -> String -> Xprez doc node clip typeD idc str = bold $ presType str `withColor` typeDCol -- idc is never used for type decls. derCol = green opCol = black keyCol = blue sepCol = brown consCol = black typeDCol = purple --darkViolet focusCol = lightBlue -- lightGrey commentCol = (240,240,240) --idC = unsafePerformIO $ newIORef (0 :: Int) --newIDP _ = IDP $ unsafePerformIO $ do {modifyIORef idC (+1); readIORef idC} -- oparen pprec cprec = if pprec > cprec then [text "("] else [] -- cparen pprec cprec = if pprec > cprec then [text ")"] else [] --addloc exp pth pres = loc (ExpNode exp pth) idCounter = unsafePerformIO $ newIORef (0 :: Int) -- needs a fresh arg to prevent sharing. newIDP _ = IDP $ unsafePerformIO $ do {modifyIORef idCounter (+1); readIORef idCounter} mkIDP NoIDP idC offset = IDP (idC + offset) mkIDP id@(IDP _) _ _ = id } -------------------------------------------------------------- -- -- Experimental: automatic layout -- It should be possible to use combinators and compute a lot of things automatically, as long as -- string only presentations are used -- computation of col should be based on either old layout or computed layout, so automatic layout -- can be mixed with normal layout -- -- Furthermore, type sigs should be part of the grammar and structurals should have whitespace -------------------------------------------------------------- {- CREATION OF NEW PRES ELTS: Can't change the doc->pres mapping, but if we make new pres elts, just give them a unique id, and on parsing, the doc->pres mapping will be set correctly -} -- merge the counters ATTR EnrichedDoc List_Decl ConsList_Decl Decl Ident Exp List_Exp ConsList_Exp List_Alt ConsList_Alt Alt [ | layoutMap : LayoutMap | ] ATTR List_Decl ConsList_Decl Decl Ident Exp List_Exp ConsList_Exp List_Alt ConsList_Alt Alt [ | newlines, spaces, col : Int | ] SEM EnrichedDoc | RootEnr --lhs.layoutMap = @lhs.layoutMap -- no auto layout decls.layoutMap = @lhs.layoutMap decls.col = 0 decls.newlines = 1 decls.spaces = 0 lhs.layoutMap = @decls.layoutMap -- to get good type sig layout behaviour, layout must be fixed when sig appears for the first time, -- as well as when a sig has disappeared (last one might be tricky to detect). --SEM Decls -- | ConsDecls decl.col = @lhs.col -- decls.col = @lhs.col SEM Decl -- nested decls do produce auto layout, so top level decl can determine whether to use it. | Decl lhs.layoutMap = let lm = if @autoLayout.bool || @lhs.level /= 0 then @exp.layoutMap else @lhs.layoutMap in if @idP2 /= NoIDP || @lhs.level /= 0 then lm else case lookupFM lm (@ident.firstToken) of Just (nwln,sp) -> addListToFM lm [ (mkIDP @idP2 @lhs.pIdC 2,(nwln,sp)) , (@ident.firstToken, (1,sp)) ] _ -> addToFM lm (mkIDP @idP2 @lhs.pIdC 2) (1,0) -- the whitespace from the first token is used to create whitespace for the type sig ident.layoutMap = addListToFM @lhs.layoutMap [(@idP0, (0,1)), (@idP1, (0,0))] ident.col = @lhs.col ident.newlines = @lhs.newlines ident.spaces = @lhs.spaces exp.col = @ident.col+2+1 -- " = " exp.newlines = 0 exp.spaces = 1 lhs.col = @lhs.col lhs.newlines = 1 lhs.spaces = @lhs.col SEM Ident [ | | firstToken : IDP ] | Ident lhs.layoutMap = addToFM @lhs.layoutMap @idP0 (@lhs.newlines,@lhs.spaces) lhs.col = @lhs.col+ length @string_.str lhs.firstToken = @idP0 | ParseErrIdent lhs.firstToken = NoIDP | HoleIdent lhs.firstToken = NoIDP -- put layout for tokens in front of layoutMap and pass on to left child, or parent (chain) -- assign correct col's for children, possibly using synthesized col's from children -- assign (or add) whitespace to newlines and spaces attrs, which will be set to first token in chain SEM Exp | PlusExp exp1.layoutMap = addToFM @lhs.layoutMap @idP0 (0,1) exp1.col = @lhs.col exp2.col = @exp1.col + 3 exp2.newlines = 0 exp2.spaces = 1 lhs.col = @exp2.col | TimesExp exp1.layoutMap = addToFM @lhs.layoutMap @idP0 (0,1) exp1.col = @lhs.col exp2.col = @exp1.col + 3 exp2.newlines = 0 exp2.spaces = 1 lhs.col = @exp2.col | DivExp exp1.layoutMap = addToFM @lhs.layoutMap @idP0 (0,0) exp1.col = 0 exp1.newlines = 0 exp1.spaces = 0 exp2.col = 0 exp2.newlines = 0 exp2.spaces = 0 lhs.col = @exp1.col | PowerExp exp1.layoutMap = addToFM @lhs.layoutMap @idP0 (0,0) exp1.col = @lhs.col exp2.col = 0 exp2.newlines = 0 exp2.spaces = 0 lhs.col = @exp2.col | IntExp lhs.layoutMap = addToFM @lhs.layoutMap @idP0 (@lhs.newlines,@lhs.spaces) lhs.col = @lhs.col+length (show @int_.int) | BoolExp lhs.layoutMap = addToFM @lhs.layoutMap @idP0 (@lhs.newlines,@lhs.spaces) | LamExp ident.layoutMap = addListToFM @lhs.layoutMap [ (@idP0, (@lhs.newlines,@lhs.spaces)) , (@idP1, (0,1)) ] ident.col = @lhs.col + 1 -- "\" ident.newlines = 0 ident.spaces = 0 exp.col = @ident.col + 3 -- "\arrow" 4 --" -> " exp.newlines = 0 exp.spaces = 1 lhs.col = @exp.col | AppExp exp1.layoutMap = @lhs.layoutMap exp2.col = @exp1.col+1 --" " exp2.newlines = 0 exp2.spaces = 1 lhs.col = @lhs.col | CaseExp exp.layoutMap = addListToFM @lhs.layoutMap [ (@idP0, (@lhs.newlines,@lhs.spaces)) , (@idP1, (0,1)) ] exp.col = @lhs.col + 5 -- "case " exp.newlines = 0 exp.spaces = 1 alts.col = @lhs.col + 2 -- indented 2 relative to "case" keyword alts.newlines = 1 alts.spaces = @lhs.col + 2 lhs.col = @alts.col alts.totalMaxLHSLength = @alts.maxLHSLength | LetExp decls.layoutMap = addListToFM @lhs.layoutMap [ (@idP0, (@lhs.newlines,@lhs.spaces)) , (@idP1, (1,@lhs.col))] decls.col = @lhs.col + 3+1 -- "let " exp.col = @lhs.col + 3+1 -- "in " decls.newlines = 0 decls.spaces = 1 exp.newlines = 0 exp.spaces = 2 -- | IdentExp Chained | IfExp exp1.layoutMap = addListToFM @lhs.layoutMap [ (@idP0, (@lhs.newlines,@lhs.spaces)) , (@idP1, (1,@lhs.col)) , (@idP2, (1,@lhs.col)) ] exp1.col = @lhs.col + 2+1 -- "if " exp2.col = @lhs.col + 4+1 -- "then " exp3.col = @lhs.col + 4+1 -- "else " exp1.newlines = 0 exp1.spaces = 1 exp2.newlines = 0 exp2.spaces = 1 exp3.newlines = 0 exp3.spaces = 1 | ParenExp exp.layoutMap = addListToFM @lhs.layoutMap [ (@idP0, (@lhs.newlines,@lhs.spaces)) , (@idP1, (0,1)) ] exp.col = @lhs.col + 1+1 -- "( " exp.newlines = 0 exp.spaces = 1 lhs.col = @exp.col + 1+1 --" )" lhs.newlines = 0 lhs.spaces = 0 | ListExp exps.layoutMap = addListToFM @lhs.layoutMap [ (@idP0, (@lhs.newlines,@lhs.spaces)) , (@idP1, (0,1)) ] exps.col = @lhs.col + 1+1 -- "[ " exps.newlines = 0 exps.spaces = 1 lhs.col = @exps.col + 1+1 --" ]" lhs.newlines = 0 lhs.spaces = 0 | ProductExp exps.layoutMap = addListToFM @lhs.layoutMap [ (@idP0, (@lhs.newlines,@lhs.spaces)) , (@idP1, (0,1)) ] exps.col = @lhs.col + 1+1 -- "( " exps.newlines = 0 exps.spaces = 1 lhs.col = @exps.col + 1+1 --" )" lhs.newlines = 0 lhs.spaces = 0 SEM ConsList_Exp -- all exps get same (newlines, spaces) | Cons_Exp tail.col = @head.col + 2 --", " -- alts compute a maximum lefthand side length, that is sent back down at the case node. SEM Alt [ totalMaxLHSLength : Int | | lhsLength : Int ] | Alt ident.layoutMap = addListToFM @lhs.layoutMap [(@idP0, (0,@lhs.totalMaxLHSLength - @lhsLength+1)), (@idP1, (0,0))] ident.col = @lhs.col ident.newlines = @lhs.newlines ident.spaces = @lhs.spaces exp.col = @ident.col+ @lhs.totalMaxLHSLength - @lhsLength + 3 -- "\arrow" 4 -- " -> " exp.newlines = 0 exp.spaces = 1 lhs.col = @lhs.col lhs.newlines = 1 lhs.spaces = @lhs.col loc.lhsLength = length $ strFromIdent @ident.self | HoleAlt lhs.lhsLength = 0 | ParseErrAlt lhs.lhsLength = 0 SEM List_Alt [ totalMaxLHSLength : Int | | maxLHSLength : Int ] | HoleList_Alt lhs.maxLHSLength = 0 | ParseErrList_Alt lhs.maxLHSLength = 0 SEM ConsList_Alt [ totalMaxLHSLength : Int | | maxLHSLength : Int ] | Cons_Alt lhs.maxLHSLength = @head.lhsLength `max` @tail.maxLHSLength | Nil_Alt lhs.maxLHSLength = 0 -------------------------------------------------------------- -- -- Simple Type computations -- -------------------------------------------------------------- { data TypeTree = TypeNode TypeInfo [TypeTree] data TypeInfo = TypeInfo String (Maybe String) } -- type of declaration ATTR Decl [ | | typeStr : {Maybe String} ] SEM Decl | Decl loc.typeStr = case lookup (strFromIdent @ident.self) @lhs.topLevelEnv of Nothing -> Nothing Just tp -> Just $ strFromIdent @ident.self ++ " :: "++ tp | BoardDecl loc.typeStr = Nothing | PPPresentationDecl loc.typeStr = Nothing | HoleDecl loc.typeStr = Nothing | ParseErrDecl loc.typeStr = Nothing -- variables in scope ATTR List_Decl ConsList_Decl Decl Ident Exp List_Exp ConsList_Exp List_Alt ConsList_Alt Alt [ varsInScope : {FiniteMap String (PathDoc, String)} | varsInScopeAtFocus : {FiniteMap String (PathDoc, String)} | ] -- path needs to be accessible from parent, or is that just now? SEM EnrichedDoc | RootEnr --loc.varsInScope = addListToFM (unitFM "" (NoPathD, "")) @decls.declaredVars loc.varsInScope = listToFM @decls.declaredVars SEM Exp | LetExp loc.varsInScope = addListToFM @lhs.varsInScope @decls.declaredVars | LamExp exp.varsInScope = addToFM @lhs.varsInScope (strFromIdent @ident.self) (PathD $ (@lhs.path++[0]), @exp.type) ATTR List_Decl ConsList_Decl Decl [ | | declaredVars USE {++} {[]} : {[(String,(PathDoc,String))]} ] SEM Decl | Decl lhs.declaredVars = [(strFromIdent @ident.self, (PathD (@lhs.path++[2]), @exp.type))] -- collect the variables in scope at focus SEM EnrichedDoc | RootEnr decls.varsInScopeAtFocus = emptyFM -- a maybe is better SEM Decl | Decl ident.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus SEM Ident | Ident lhs.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus -- TODO: group constructors SEM Exp | PlusExp exp1.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | TimesExp exp1.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | DivExp exp1.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | PowerExp exp1.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | BoolExp lhs.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | IntExp lhs.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | LamExp ident.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | AppExp exp1.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | CaseExp alts.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | LetExp decls.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | IdentExp ident.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | IfExp exp1.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | ParenExp exp.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | ListExp exps.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus | ProductExp exps.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus SEM Alt | Alt ident.varsInScopeAtFocus = if (PathD @lhs.path) == @lhs.focusD then @lhs.varsInScope else @lhs.varsInScopeAtFocus -- lists can't have focus, only at top (but that's not handled correctly now) -- so only collect varsInScopeAtFocus from below. Not clear whether in focus is really interesting for -- the lists in the document (/= lists in program) SEM Exp [ | | type : String ] | PlusExp loc.type = lookupType @lhs.typeEnv @lhs.path | TimesExp loc.type = lookupType @lhs.typeEnv @lhs.path | DivExp loc.type = lookupType @lhs.typeEnv @lhs.path | PowerExp loc.type = lookupType @lhs.typeEnv @lhs.path | BoolExp loc.type = lookupType @lhs.typeEnv @lhs.path | IntExp loc.type = lookupType @lhs.typeEnv @lhs.path | LamExp loc.type = lookupType @lhs.typeEnv @lhs.path | AppExp loc.type = lookupType @lhs.typeEnv @lhs.path | CaseExp loc.type = lookupType @lhs.typeEnv @lhs.path | LetExp loc.type = lookupType @lhs.typeEnv @lhs.path | IdentExp loc.type = lookupType @lhs.typeEnv @lhs.path | IfExp loc.type = lookupType @lhs.typeEnv @lhs.path | ParenExp loc.type = lookupType @lhs.typeEnv @lhs.path | ListExp loc.type = lookupType @lhs.typeEnv @lhs.path | ProductExp loc.type = lookupType @lhs.typeEnv @lhs.path | HoleExp loc.type = "" | ParseErrExp loc.type = "" { lookupType typeEnv path = case lookup (PathD path) typeEnv of Nothing -> "" -- use Maybe here? Just tp -> tp } -------------------------------------------------------------- -- -- Silly Evaluator -- -------------------------------------------------------------- { type Bindings = [Binding] type Binding = (String, Value) data Value = BoolVal Bool | IntVal Int | LamVal (Value -> Value) | ListVal [Value] | ProdVal [Value] | ErrVal instance Show Value where show (BoolVal b) = show b show (IntVal i) = show i show (LamVal _) = "" show (ListVal vs) = "[" ++ concat (intersperse ", " (map show vs)) ++ "]" show (ProdVal vs) = "(" ++ concat (intersperse ", " (map show vs)) ++ ")" show (ErrVal) = "" {- evaluate :: Exp -> [(String, Val)] -> Val evaluate (Lam ident exp) env = evaluate (AppExp f a) env = -} evaluateIntOp op (IntVal v1) (IntVal v2) = IntVal $ v1 `op` v2 evaluateIntOp _ _ _ = ErrVal } SEM EnrichedDoc | RootEnr decls.env = @decls.dcls SEM List_Decl [ env : Bindings | | dcls : Bindings ] | ParseErrList_Decl lhs.dcls = [] | HoleList_Decl lhs.dcls = [] SEM ConsList_Decl [ env : Bindings | | dcls : Bindings ] | Cons_Decl lhs.dcls = @head.dcl : @tail.dcls | Nil_Decl lhs.dcls = [] SEM Decl [ env : Bindings | | dcl : Binding ] | Decl lhs.dcl = (@ident.str, @exp.val) | BoardDecl lhs.dcl = ("XXXXXX", ErrVal) -- should be done nicely with Maybe | PPPresentationDecl lhs.dcl = ("XXXXXX", ErrVal) -- should be done nicely with Maybe | HoleDecl lhs.dcl = ("XXXXXX", ErrVal) -- should be done nicely with Maybe | ParseErrDecl lhs.dcl = ("XXXXXX", ErrVal) SEM Ident [ || str : String ] | Ident lhs.str = @string_.str | HoleIdent lhs.str = "" | ParseErrIdent lhs.str = "" -- could retrieve the old value SEM Exp [ env : Bindings | | val : Value ] | PlusExp lhs.val = evaluateIntOp (+) @exp1.val @exp2.val | TimesExp lhs.val = evaluateIntOp (*) @exp1.val @exp2.val | DivExp lhs.val = case @exp2.val of IntVal 0 -> ErrVal IntVal _ -> evaluateIntOp div @exp1.val @exp2.val _ -> ErrVal | PowerExp lhs.val = evaluateIntOp (^) @exp1.val @exp2.val --case (@exp1.val, @exp2.val) of -- (IntVal i1, IntVal i2) -> BoolVal $ i1 == i2 -- (BoolVal b1, BoolVal b2) -> BoolVal $ b1 == b2 -- (_,_) -> ErrVal | BoolExp lhs.val = BoolVal @bool_.bool | IntExp lhs.val = IntVal @int_.int | LamExp lhs.val = -- @exp :: Bindings -> FocusDoc -> Int -> [Int] -> (Int,Presentation, Exp, Value) LamVal (\arg -> let (_,_,_,_,_,_,_,_,_,_,_,_,v,_) = @exp undefined ((@ident.str, arg): @lhs.env) undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined in v) -- dirty hack because AG does not allow this easily | AppExp lhs.val = case @exp1.val of LamVal f -> f @exp2.val _ -> ErrVal | CaseExp lhs.val = case lookup "a" @alts.alts of {Just v -> v; Nothing -> ErrVal} | LetExp lhs.val = --@exp :: Int -> Bindings -> FocusDoc -> Int -> [Int] -> (Int,Presentation, Exp, Value) let (_,_,_,_,_,_,_,_,_,_,_,_,v,_) = @exp undefined (@decls.dcls ++ @lhs.env) undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined in v -- dirty hack because AG does not allow this easily | IdentExp lhs.val = case lookup @ident.str @lhs.env of { Just v -> v; Nothing -> ErrVal } | IfExp lhs.val = case @exp1.val of BoolVal b -> if b then @exp2.val else @exp3.val _ -> ErrVal | ParenExp lhs.val = @exp.val | ListExp lhs.val = ListVal @exps.vals | ProductExp lhs.val = ProdVal @exps.vals | HoleExp lhs.val = ErrVal | ParseErrExp lhs.val = ErrVal SEM List_Exp [ env : Bindings || vals : {[Value]} ] | ParseErrList_Exp lhs.vals = [] | HoleList_Exp lhs.vals = [] SEM ConsList_Exp [ env : Bindings | | vals : {[Value]} ] | Cons_Exp lhs.vals = @head.val : @tail.vals | Nil_Exp lhs.vals = [] SEM List_Alt [ env : Bindings | | alts : Bindings ] | ParseErrList_Alt lhs.alts = [] | HoleList_Alt lhs.alts = [] SEM ConsList_Alt [ env : Bindings | | alts : Bindings ] | Cons_Alt lhs.alts = @head.alt : @tail.alts | Nil_Alt lhs.alts = [] SEM Alt [ env : Bindings | | alt : Binding ] | Alt lhs.alt = (@ident.str, @exp.val) | HoleAlt lhs.alt = ("XXXXXX", ErrVal) -- should be done nicely with Maybe | ParseErrAlt lhs.alt = ("XXXXXX", ErrVal) -------------------------------------------------------------- -- -- Chessboard -- -------------------------------------------------------------- -- presentation SEM Decl | BoardDecl lhs.pres = loc (DeclNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ row' [text' (mkIDP @idP0 @lhs.pIdC 0) "Chess: ", @board.pres] SEM Board [ | | ] | Board lhs.pres = loc (BoardNode @self @lhs.path) $ presentFocus @lhs.focusD @lhs.path $ structural $ colR 4 (reverse [@r1.pres,@r2.pres,@r3.pres,@r4.pres,@r5.pres,@r6.pres,@r7.pres,@r8.pres]) r1.rowNr = 0 r1.sqCol = False loc.possibleMoves = case @r8.focusedPiece of Just (square, (r,c)) -> Chess.computeMoves @self (r,c) Nothing -> [] r1.focusedPiece = Nothing SEM BoardRow [ possibleMoves : {[(Int, Int)]}| sqCol : Bool rowNr : Int focusedPiece : { Maybe (BoardSquare,(Int,Int)) } | ] | BoardRow lhs.pres = loc (BoardRowNode @self @lhs.path) $ presentFocus @lhs.focusD @lhs.path $ structural $ row' [@ca.pres,@cb.pres,@cc.pres,@cd.pres,@ce.pres,@cf.pres,@cg.pres,@ch.pres] lhs.sqCol = not @lhs.sqCol lhs.rowNr = 1 + @lhs.rowNr ca.colNr = 0 SEM BoardSquare [ possibleMoves : {[(Int, Int)]} rowNr : Int | focusedPiece : { Maybe (BoardSquare,(Int,Int)) } sqCol : Bool colNr : Int | ] | King lhs.pres = loc (KingNode @self @lhs.path) $ structural $ Chess.piece @self @color @lhs.sqCol @lhs.rowNr @lhs.colNr @lhs.possibleMoves @lhs.focusD @lhs.path lhs.sqCol = not @lhs.sqCol lhs.colNr = 1 + @lhs.colNr lhs.focusedPiece = if (PathD @lhs.path) == @lhs.focusD then Just (@self, (@lhs.colNr,@lhs.rowNr)) else @lhs.focusedPiece | Queen lhs.pres = loc (QueenNode @self @lhs.path) $ structural $ Chess.piece @self @color @lhs.sqCol @lhs.rowNr @lhs.colNr @lhs.possibleMoves @lhs.focusD @lhs.path lhs.sqCol = not @lhs.sqCol lhs.colNr = 1 + @lhs.colNr lhs.focusedPiece = if (PathD @lhs.path) == @lhs.focusD then Just (@self, (@lhs.colNr,@lhs.rowNr)) else @lhs.focusedPiece | Bishop lhs.pres = loc (BishopNode @self @lhs.path) $ structural $ Chess.piece @self @color @lhs.sqCol @lhs.rowNr @lhs.colNr @lhs.possibleMoves @lhs.focusD @lhs.path lhs.sqCol = not @lhs.sqCol lhs.colNr = 1 + @lhs.colNr lhs.focusedPiece = if (PathD @lhs.path) == @lhs.focusD then Just (@self, (@lhs.colNr,@lhs.rowNr)) else @lhs.focusedPiece | Knight lhs.pres = loc (KnightNode @self @lhs.path) $ structural $ Chess.piece @self @color @lhs.sqCol @lhs.rowNr @lhs.colNr @lhs.possibleMoves @lhs.focusD @lhs.path lhs.sqCol = not @lhs.sqCol lhs.colNr = 1 + @lhs.colNr lhs.focusedPiece = if (PathD @lhs.path) == @lhs.focusD then Just (@self, (@lhs.colNr,@lhs.rowNr)) else @lhs.focusedPiece | Rook lhs.pres = loc (RookNode @self @lhs.path) $ structural $ Chess.piece @self @color @lhs.sqCol @lhs.rowNr @lhs.colNr @lhs.possibleMoves @lhs.focusD @lhs.path lhs.sqCol = not @lhs.sqCol lhs.colNr = 1 + @lhs.colNr lhs.focusedPiece = if (PathD @lhs.path) == @lhs.focusD then Just (@self, (@lhs.colNr,@lhs.rowNr)) else @lhs.focusedPiece | Pawn lhs.pres = loc (PawnNode @self @lhs.path) $ structural $ Chess.piece @self @color @lhs.sqCol @lhs.rowNr @lhs.colNr @lhs.possibleMoves @lhs.focusD @lhs.path lhs.sqCol = not @lhs.sqCol lhs.colNr = 1 + @lhs.colNr lhs.focusedPiece = if (PathD @lhs.path) == @lhs.focusD then Just (@self, (@lhs.colNr,@lhs.rowNr)) else @lhs.focusedPiece | Empty lhs.pres = loc (EmptyNode @self @lhs.path) $ structural $ Chess.piece @self False @lhs.sqCol @lhs.rowNr @lhs.colNr @lhs.possibleMoves @lhs.focusD @lhs.path lhs.sqCol = not @lhs.sqCol lhs.colNr = 1 + @lhs.colNr ------------------------- Identifier list presentation -- can we mix pres with idsPres? ATTR List_Decl ConsList_Decl Decl Ident [ || idsPres : Presentation_Doc_Node_Clip ] SEM List_Decl | List_Decl lhs.idsPres = loc (List_DeclNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ @elts.idsPres | HoleList_Decl lhs.idsPres = presHole @lhs.focusD "Decls" (HoleList_DeclNode @self @lhs.path) @lhs.path | ParseErrList_Decl lhs.idsPres = empty -- must be empty, otherwise initDoc hack fails SEM ConsList_Decl | Cons_Decl lhs.idsPres = row' [ @head.idsPres, text " ", @tail.idsPres ] | Nil_Decl lhs.idsPres = empty SEM Decl | Decl lhs.idsPres = loc (DeclNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row' [ text "'", @ident.idsPres, text "';" ] | BoardDecl lhs.idsPres = loc (BoardDeclNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row' [ text "board;" ] | PPPresentationDecl lhs.idsPres = loc (PPPresentationDeclNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row' [ text "slides;" ] | HoleDecl lhs.idsPres = presHole @lhs.focusD "Decl" (HoleDeclNode @self @lhs.path) @lhs.path | ParseErrDecl lhs.idsPres = presParseErr @node @presentation SEM Ident | Ident lhs.idsPres = loc (IdentNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ row' [ @string_.pres ] | HoleIdent lhs.idsPres = presHole @lhs.focusD "Ident" (HoleIdentNode @self @lhs.path) @lhs.path | ParseErrIdent lhs.idsPres = presParseErr @node @presentation SEM EnrichedDoc -- don't understand why this is necessary, it should not be used. However, without ag eval crashes | RootEnr idListDecls.col = 0 -- auto layout idListDecls.newlines = 0 -- idListDecls.spaces = 0 -- idListDecls.level = 0 -- not right idListDecls.errs = [] idListDecls.env = [] idListDecls.varsInScopeAtFocus = emptyFM idListDecls.ranges = ([],[],[]) -- idListDecls.ix = 0 -- idListDecls.path = [] ------------------------- PowerPoint stuff: -- heliumItems don't have auto layout and other tricks yet. SEM Item | HeliumItem exp.col = 0 -- auto layout exp.newlines = 0 -- exp.spaces = 0 -- exp.level = 0 -- not right exp.layoutMap = emptyFM exp.errs = [] exp.typeEnv = [] exp.topLevelEnv = [] exp.env = [] ATTR PPPresentation List_Slide ConsList_Slide Slide ItemList ListType List_Item ConsList_Item Item [ varsInScope : {FiniteMap String (PathDoc, String)} | varsInScopeAtFocus : {FiniteMap String (PathDoc, String)} | ] ATTR PPPresentation List_Slide ConsList_Slide Slide ItemList ListType List_Item ConsList_Item Item [ ranges : {([PathDoc],[PathDoc],[PathDoc])} | | ] SEM Decl | PPPresentationDecl lhs.pres = loc (PPPresentationDeclNode @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ row' [ text' (mkIDP @idP0 @lhs.pIdC 0) "Slides: ", @pPPresentation.pres ] SEM PPPresentation | PPPresentation lhs.pres = loc (PPPresentationNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' $ [ row' [-- text "View type: ", if @viewType.bool then (box $ text $ "XML view") `addPopupItems` [("Change to presentation view",toggleViewType @lhs.path @self)] else (box $ text $"Presentation view") `addPopupItems` [("Change to XML view",toggleViewType @lhs.path @self)] ] , vSpace 10 ] ++ if @viewType.bool then [ text "" , @slides.pres , text "" ] else [ @slides.pres2 ] -- then (box $ text $ "Edit view") `addPopupItems` [("Change to presentation view",toggleViewType @lhs.path @self)] -- else (box $ text $"Presentation view") `addPopupItems` [("Change to edit view",toggleViewType @lhs.path @self)] -- [ row' [ text "pres ",key NoIDP "=",text " Presentation ", text " $"] -- , row' [ text " ", @slides.pres] SEM List_Slide [ || pres : Presentation_Doc_Node_Clip ] | List_Slide lhs.pres = loc (List_SlideNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presentList @elts.press | ParseErrList_Slide lhs.pres = loc (List_SlideNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presParseErr @node @presentation | HoleList_Slide -- remove this line? lhs.pres = loc (List_SlideNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presHole @lhs.focusD "Slides" (HoleList_SlideNode @self @lhs.path) @lhs.path { presentList [] = empty presentList ps = row' [ text " ", col' ps ] {-presentList (p:ps) = col' $ [ row' [sep NoIDP " [ ", p ] ] ++ [ row' [sep NoIDP " , ", p]| p <- ps ] ++ [ sep NoIDP " ] "] -} } SEM Slide | Slide lhs.pres = loc (SlideNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' [ row' [ text "", row' [ text "", @title.pres `withColor` darkViolet , text "" ]] , row' [ text " ", @itemList.pres ] , text "" ] {-| Slide lhs.pres = loc (SlideNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' [ row' [ text "Slide ", row' [ text "\"", @title.pres, text "\"" ] `withColor` darkViolet , text " $"] , row' [ text " ", @itemList.pres ] ] -} SEM ItemList | ItemList lhs.pres = loc (ItemListNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' [ row' [ text ""] , @items.pres , text "" ] {- | ItemList lhs.pres = loc (ItemListNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' [ row' [ text "ItemList ", @listType.pres, text " $"] , @items.pres ] -} SEM List_Item [ || pres : Presentation_Doc_Node_Clip ] | List_Item lhs.pres = loc (List_ItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presentList @elts.press | ParseErrList_Item lhs.pres = loc (List_ItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presParseErr @node @presentation | HoleList_Item lhs.pres = loc (List_ItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presHole @lhs.focusD "Items" (HoleList_ItemNode @self @lhs.path) @lhs.path SEM ListType | Bullet lhs.pres = loc (BulletNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ text "Bullet" | Number lhs.pres = loc (NumberNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ text "Number" | Alpha lhs.pres = loc (AlphaNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ text "Alpha" SEM Item | StringItem lhs.pres = loc (StringItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row' [ text "", @string.pres `withColor` darkViolet, text "" ] | HeliumItem lhs.pres = loc (HeliumItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' [ text "" , row [text " ", @exp.pres] , text "" ] | ListItem lhs.pres = loc (ListItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' [ text "" , row [text " ", @itemList.pres] , text "" ] {-| StringItem lhs.pres = loc (StringItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row' [ text "StringItem " , row' [ text "\"" , @string.pres , text "\"" ] `withColor` darkViolet ] | HeliumItem lhs.pres = loc (HeliumItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' [ text "HeliumItem $" , row [text " ", @exp.pres] ] | ListItem lhs.pres = loc (ListItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' [ text "ListItem $" , row [text " ", @itemList.pres] ] -} -- parsing must be inside then quotes because scanner has no string support yet -- also the string has to be an identifier, which is a bit restricted -- several scanning styles probably have to be mixed in the document (Haskell, free text, etc.) --SEM String_ -- | String_ -- lhs.pres = row' [ text "\"" -- , loc (String_Node @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ -- row' [text @string, text ""] -- ? why this empty string? -- , text "\"" -- ] `withColor` darkViolet { -- many Document refs may be doc when editPasteD is fixed toggleViewType :: [Int] -> PPPresentation -> UpdateDoc Document clip toggleViewType pth (PPPresentation idD viewtp slides) = \(DocumentLevel d path cl) -> let (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD pth) (Clip_PPPresentation (PPPresentation idD (Bool_ NoIDD (not $ boolVal viewtp)) slides)) ) in (DocumentLevel d' path cl) } ATTR Slide ItemList {- ListType -} Item [ || pres2 : Presentation_Doc_Node_Clip ] ATTR List_Slide ConsList_Slide List_Item ConsList_Item [ || press2 : {[Presentation_Doc_Node_Clip]} ] SEM List_Slide [ || pres2 : Presentation_Doc_Node_Clip ] | List_Slide lhs.pres2 = loc (List_SlideNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' $ intersperse (col' [vSpace 4, hLine, vSpace 4]) @elts.press2 | ParseErrList_Slide lhs.pres2 = loc (List_SlideNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presParseErr @node @presentation | HoleList_Slide lhs.pres2 = loc (List_SlideNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presHole @lhs.focusD "Slides" (HoleList_SlideNode @self @lhs.path) @lhs.path SEM Slide | Slide lhs.pres2 = loc (SlideNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ slide @title.pres @itemList.pres2 -- Tricky: need to put an invisible structural presentation of listTypeNode, because -- makeStructuralListType expects it SEM ItemList | ItemList lhs.pres2 = loc (ItemListNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row' [ @listType.pres2 , @items.pres2 ] -- list gets loc and structural items.listType = @listType.self items.typeLoc = @listType.typeLoc SEM ListType [ || pres2 : Presentation_Doc_Node_Clip typeLoc : {Presentation_Doc_Node_Clip -> Presentation_Doc_Node_Clip}] | Bullet lhs.pres2 = loc (BulletNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ empty lhs.typeLoc = loc (BulletNode @self @lhs.path) | Number lhs.pres2 = loc (NumberNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ empty lhs.typeLoc = loc (NumberNode @self @lhs.path) | Alpha lhs.pres2 = loc (AlphaNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ empty lhs.typeLoc = loc (AlphaNode @self @lhs.path) | ParseErrListType lhs.typeLoc = id | HoleListType lhs.typeLoc = id SEM List_Item [ || pres2 : Presentation_Doc_Node_Clip ] | List_Item lhs.pres2 = loc (List_ItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col' @elts.press2 | ParseErrList_Item lhs.pres2 = loc (List_ItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presParseErr @node @presentation | HoleList_Item lhs.pres2 = loc (List_ItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ presHole @lhs.focusD "Items" (HoleList_ItemNode @self @lhs.path) @lhs.path SEM Item [ listType : ListType typeLoc : {Presentation_Doc_Node_Clip -> Presentation_Doc_Node_Clip} || ] | StringItem lhs.pres2 = loc (StringItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row' [itemStart @lhs.ix @lhs.listType @lhs.typeLoc, @string.pres] | HeliumItem lhs.pres2 = loc (HeliumItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row' [itemStart @lhs.ix @lhs.listType @lhs.typeLoc, @exp.pres `withColor` black `withbgColor` white `withFontFam` "Courier New" `withFontSize_` (\s->s-3) ] | ListItem lhs.pres2 = loc (ListItemNode @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row' [ hSpace 25, @itemList.pres2 `withFontSize_` (\fs -> if fs > 5 then fs * 80 `div` 100 else fs) ] { itemStart i (Bullet _) typeLoc = typeLoc $ text "- " itemStart i (Number _) typeLoc = typeLoc $ text (show (i+1) ++ ") ") itemStart i (Alpha _) typeLoc = typeLoc $ text (chr (ord 'a' + i):") ") itemStart i (_) typeLoc = typeLoc $ text " " } SEM ConsList_Slide | Cons_Slide lhs.press2 = @head.pres2 : @tail.press2 | Nil_Slide lhs.press2 = [] ATTR List_Item [ listType : ListType typeLoc : {Presentation_Doc_Node_Clip -> Presentation_Doc_Node_Clip} || ] SEM ConsList_Item [ listType : ListType typeLoc : {Presentation_Doc_Node_Clip -> Presentation_Doc_Node_Clip} || ] | Cons_Item lhs.press2 = @head.pres2 : @tail.press2 head.listType = @lhs.listType head.typeLoc = @lhs.typeLoc | Nil_Item lhs.press2 = [] SEM List_Slide | HoleList_Slide lhs.press2 = [presHole @lhs.focusD "Slides" (HoleList_SlideNode @self @lhs.path) @lhs.path] | ParseErrList_Slide lhs.press2 = [presParseErr @node @presentation] SEM Slide | HoleSlide lhs.pres2 = presHole @lhs.focusD "Slide" (HoleSlideNode @self @lhs.path) @lhs.path | ParseErrSlide lhs.pres2 = presParseErr @node @presentation SEM ItemList | HoleItemList lhs.pres2 = presHole @lhs.focusD "ItemList" (HoleItemListNode @self @lhs.path) @lhs.path | ParseErrItemList lhs.pres2 = presParseErr @node @presentation SEM ListType | HoleListType lhs.pres2 = presHole @lhs.focusD "ListType" (HoleListTypeNode @self @lhs.path) @lhs.path | ParseErrListType lhs.pres2 = presParseErr @node @presentation SEM List_Item | HoleList_Item lhs.press2 = [presHole @lhs.focusD "Items" (HoleList_ItemNode @self @lhs.path) @lhs.path] | ParseErrList_Item lhs.press2 = [presParseErr @node @presentation] SEM Item | HoleItem lhs.pres2 = presHole @lhs.focusD "Item" (HoleItemNode @self @lhs.path) @lhs.path | ParseErrItem lhs.pres2 = presParseErr @node @presentation -- boxed String -- in order to set the idp of the string, parents must show an text idp "" before it. -- we need to find a more elegant solution for this -- also the reusing is not ok. We want to reuse the parent from this string token, but if a locator -- is added, then we can only reuse the String token itself. However, without a locator, the string -- cannot be selected by clicking, since its parent will be selected. -- Probably, the parser will have to take into account primitive locators, and ignore them -- TODO: -- add boxed bool -- get primitive bits out of generator, and disable navigate/edit in them -- fix XML presentation -- clean up parser -- add XML/tree recognizer -- figure out nice functions & attributes for boxing/unboxing and put them in utils. -- Boxed values should not have IDD, but generator can't handle types without IDD yet. SEM String_ | String_ lhs.pres = loc (String_Node @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ row' [text @string, text ""] -- ? why this empty string? SEM String_ [ | | length : Int str : String ] | String_ lhs.length = length @string lhs.str = @string | ParseErrString_ HoleString_ lhs.length = 0 lhs.str = "" SEM Int_ | Int_ lhs.pres = loc (Int_Node @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ row' [text $ show @int, text ""] -- ? why this empty string? SEM Int_ [ | | int : Int ] | Int_ lhs.int = @int | ParseErrInt_ HoleInt_ lhs.int = 0 SEM Bool_ | Bool_ lhs.pres = loc (Bool_Node @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ row' [text $ show @bool, text ""] -- ? why this empty string? SEM Bool_ [ | | bool : Bool ] | Bool_ lhs.bool = @bool | ParseErrBool_ HoleBool_ lhs.bool = False --- Required changes for boxed lists -- change EvaluateTypes.hs -- change ...Node in presentationAG -- change ProxParser to add extra List element -- change presentationAG -- remove pres attr decl and default for hole and parseErr -- idpc is bit different -- path attribution is just copy {- SEM List_Exp | List_Exp elts.path = @lhs.path -- ++ [0] SEM List_Exp | List_Exp lhs.press = map ( loc (List_ExpNode @self @lhs.path) -- . parsing -- if press is used, the parent is reponsible for setting parsing/structural . presentFocus @lhs.focusD @lhs.path ) @elts.press | ParseErrList_Exp lhs.press = [] | HoleList_Exp lhs.press = [] SEM ConsList_Exp | Cons_Exp head.path = @lhs.path++[@lhs.ix] tail.path = @lhs.path | Cons_Exp lhs.press = @head.pres : @tail.press | Nil_Exp lhs.press = [] SEM ConsList_Exp [ ix : Int | | ] | Cons_Exp tail.ix = @lhs.ix + 1 SEM List_Exp | List_Exp elts.ix = 0 SEM List_Exp | List_Exp elts.pIdC = @lhs.pIdC + 1 lhs.pIdC = @elts.pIdC SEM ConsList_Exp | Cons_Exp head.pIdC = @lhs.pIdC + 2 tail.pIdC = @head.pIdC lhs.pIdC = @tail.pIdC List & ConsList ATTR Decl Ident Exp Alt List_Exp Board BoardRow BoardSquare PPPresentation Slide ItemList ListType Item String_ Decls Alts Exps Slides Items [ path : {[Int]} | | ] List & ConsList ATTR EnrichedDoc Decl Ident Exp Alt List_Exp Board BoardRow BoardSquare PPPresentation Slide ItemList ListType Item String_ Decls Alts Exps Slides Items [ | pIdC : Int | ] List & ConsList ATTR EnrichedDoc Decl Ident Exp Alt List_Exp Board BoardRow BoardSquare PPPresentation Slide ItemList ListType Item String_ Decls Alts Exps Slides Items [ focusD : FocusDoc | | ] List & ConsList ATTR Decls Alts Exps Slides Items [ | | press : {[Presentation_Doc_Node_Clip]} ] ATTR EnrichedDoc Decl Ident Exp Alt Board BoardRow BoardSquare PPPresentation Slide ItemList ListType Item String_ [ | | pres : Presentation_Doc_Node_Clip ] ATTR Decl Ident Exp Alt List_Exp Board BoardRow BoardSquare PPPresentation Slide ItemList ListType Item String_ [ ix : Int || ] -}