imports { import Common.CommonTypes import Presentation.PresLayerTypes import Presentation.PresLayerUtils import Presentation.XprezLib import Presentation.XLatex hiding (bold) import Evaluation.DocumentEdit import List import qualified Data.Map as Map import Data.Map (Map) import Data.IORef import System.IO.Unsafe import qualified Chess import Evaluation.DocTypes (DocumentLevel (..)) import DocTypes_Generated import DocUtils_Generated import DocumentEdit_Generated } { -- inserts the elements from the list, overwriting existing old values mapInsertList :: Ord k => [(k,a)] -> Map k a -> Map k a mapInsertList lst m = Map.union (Map.fromList lst) m } INCLUDE "PresentationAG_Generated.ag" INCLUDE "LambdaReduce.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 -- 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. -} -- The following declarations prevent warnings during compilation. -- Since sem_Root is never called, the document root does not need to define these attributes -- Ideally, Document data structures are not present in the attribute grammar datatype SEM Root | Root loc.pres = empty decls.env = error "Root.decls.env should not be used" decls.errs = error "Root.decls.errs should not be used" -- decls.whitespaceMap = error "Root.decls.whitespaceMap should not be used" decls.level = error "Root.decls.level should not be used" -- decls.newlines = error "Root.decls.newlines should not be used" decls.ranges = error "Root.decls.ranges should not be used" -- decls.spaces = error "Root.decls.spaces should not be used" decls.varsInScope = error "Root.decls.varsInScope should not be used" decls.typeEnv = error "Root.decls.typeEnv should not be used" decls.topLevelEnv = error "Root.decls.topLevelEnv should not be used" decls.varsInScopeAtFocus = error "Root.decls.varsInScopeAtFocus should not be used" -------------------------------------------------------------- -- -- Document Presentation -- -------------------------------------------------------------- ATTR RootE 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 (loc.errs, loc.topLevelEnv, loc.typeEnv) = @heliumTypeInfo SEM RootE | RootE decls.level = 0 SEM Exp | LetExp decls.level = @lhs.level + 1 SEM EnrichedDoc | RootEnr loc.pres = structural $ @root.pres SEM RootE | RootE loc.pres = structural $ -- col [@idListDecls.idsPres,@decls.pres ] -- simplest presentation that still works col [ row [ hSpace 3 -- , text $ "Document focus: " ++show @lhs.focusD , case lookup @lhs.focusD @lhs.typeEnv of Nothing -> text "Focused expression has no type" `withFontFam` "verdana" Just tp -> text "Focused expression" `withFontFam` "verdana" , typeD NoIDP $ ( case lookup @lhs.focusD @lhs.typeEnv of Nothing -> "" Just tp -> " :: "++tp) ++ replicate 80 ' ' -- so hline stretches beyond longest line ] `withFontSize` 10 {- -- strange bug, uncommenting the first `with .. verdana" causes the presentation of fractions to go wrong. row [ hSpace 3 -- , text $ "Document focus: " ++show @lhs.focusD , text "Focused expression " -- `withFontFam` "verdana" , case lookup @lhs.focusD @lhs.typeEnv of Nothing -> text $ " has no type" ++ replicate 80 ' ' Just tp -> typeD NoIDP $ " :: "++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, text "module " `withColor` keyCol, bold $ text "Main" , text " where" `withColor` keyCol] , row [ hSpace 3, @decls.pres ] , empty `withHStretch` True , vSpace 10 , hLine , vSpace 4 -- empty col's are buggy in Xprez , let errs = if null @decls.parseErrors then @lhs.errs else map toMessage @decls.parseErrors in col (map presMessage errs ++ [empty]) `withFontSize` 12 , vSpace 10 , hLine , vSpace 4 , row [ hSpace 3, text "Variables in scope:" `withFont'` ("verdana",10)] , row [ hSpace 3 , col [ typeD NoIDP (var++" :: "++ tpStr) `link` pth | (var,(pth,tpStr)) <- Map.toList @decls.varsInScopeAtFocus ] ] ] `withFont'` ("Courier New",14) `withStretch` True decls.ranges = (\(l1,l2,l3)->(concat l1, concat l2, concat l3)) . unzip3 $ map pthFrmMsg @lhs.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_ 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 | List_Decl loc.pres = parsing $ row @elts.press {- SEM List_Decl | List_Decl lhs.idsPres = loc (Node_List_Decl @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ @elts.idsPres | HoleList_Decl lhs.idsPres = presHole @lhs.focusD "Decls" (Node_List_Decl @self @lhs.path) @lhs.path | ParseErrList_Decl lhs.idsPres = empty -- must be empty, otherwise initDoc hack fails -} -- see Decl lhs.whitespaceMap for rule that creates whitespace of decl with type -- sig present SEM Decl | Decl loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ (row $ (if @lhs.level == 0 then let sigIDP = mkIDP @idP2 @lhs.pIdC 2 autoLStr = if @autoLayout then " {auto layout}" else "" in case @typeStr of Nothing -> case @exp.val of ErrVal -> [ structuralToken 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 -> [ structuralToken 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 [ structuralToken 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 then [ @exp.pres, sep (mkIDP @idP1 @lhs.pIdC 1) ";" ] else [ {- boxed $ -} key (mkIDP @idP1 @lhs.pIdC 1) "..." -- `withColor` black `withbgColor` yellow -- `withMouseDown` expand @lhs.path @self ]) ) `addPopupItems` [ if @expanded then ( "Collapse: "++strFromIdent @ident.self, docUpd $ toggleExpanded @lhs.path @self) else ( "Expand: "++strFromIdent @ident.self, docUpd $ toggleExpanded @lhs.path @self)] `addPopupItems` if @lhs.level == 0 then [ if @autoLayout then ( "Disable Auto Layout", docUpd $ toggleAutoLayout @lhs.path @self) else ( "Enable Auto Layout", docUpd $ toggleAutoLayout @lhs.path @self) ] else [] SEM Ident | Ident loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ row [ token (mkIDP @idP0 @lhs.pIdC 0) @string ] {- 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 loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row [@exp1.pres , op (mkIDP @idP0 @lhs.pIdC 0) "+", @exp2.pres] | TimesExp loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row [@exp1.pres , op (mkIDP @idP0 @lhs.pIdC 0) "*", @exp2.pres] | DivExp loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ structuralToken (mkIDP @idP0 @lhs.pIdC 0) $ frac @exp1.pres @exp2.pres | PowerExp loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row [ @exp1.pres , structuralToken (mkIDP @idP0 @lhs.pIdC 0) $ power empty @exp2.pres ] -- structuralToken gets its locator from the one surrounding this parsing presentation -- It seems to work. The reason for this combined presentation is that we don't want -- the mantissa to be in the structural presentation, since then, we cannot just remove -- the exponent to get rid of the exponential expression. | BoolExp -- put the idP in an empty string before the bool presentation loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row [ token (mkIDP @idP0 @lhs.pIdC 0) $ show @bool ] | IntExp -- put the idP in an empty string before the int presentation loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row [ token (mkIDP @idP0 @lhs.pIdC 0) $ show @int] | LamExp loc.pres = parsing $ 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 [chr 174] `withFontFam` "Symbol" , key (mkIDP @idP1 @lhs.pIdC 1) "->" , @exp.pres ] | AppExp loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row [@exp1.pres, @exp2.pres] | CaseExp loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row [ key (mkIDP @idP0 @lhs.pIdC 0) "case" , @exp.pres , key (mkIDP @idP1 @lhs.pIdC 1) "of" , @alts.pres ] | LetExp loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row [ key (mkIDP @idP0 @lhs.pIdC 0) "let" , @decls.pres , key (mkIDP @idP1 @lhs.pIdC 1) "in", @exp.pres ] | IdentExp loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ @ident.pres `addPopupItems` [( "Jump to declaration of "++show (strFromIdent @ident.self) , docUpd $ navigateTo $ case Map.lookup (strFromIdent @ident.self) @lhs.varsInScope of Nothing -> NoPathD Just (pth,_) -> pth)] | IfExp loc.pres = parsing $ 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 loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row [sep (mkIDP @idP0 @lhs.pIdC 0) "(" , @exp.pres , sep (mkIDP @idP1 @lhs.pIdC 1) ")" ] | ListExp loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row $ [ sep (mkIDP @idP0 @lhs.pIdC 0) "[" , @exps.pres , sep (mkIDP @idP1 @lhs.pIdC 1) "]"] exps.ids = @ids | ProductExp loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ addReductionPopupItems @reductionEdit $ row $ [sep (mkIDP @idP0 @lhs.pIdC 0) "(" , @exps.pres , sep (mkIDP @idP1 @lhs.pIdC 1) ")"] exps.ids = @ids SEM List_Exp [ ids:{[IDP]} | | ] | List_Exp loc.pres = parsing $ let xps = @elts.press sps = map (\id -> sep id ",") (@lhs.ids++ map IDP [@lhs.pIdC .. ] ) in row $ if null xps then [] else head xps : concat [ [s,e] | (s,e) <- zip sps (tail xps)] SEM List_Alt | List_Alt loc.pres = parsing $ row @elts.press SEM Alt | Alt loc.pres = parsing $ squiggleRanges @lhs.ranges @lhs.path $ row $ [ @ident.pres , key (mkIDP @idP0 @lhs.pIdC 0) "->" -- , text' (mkIDP @idP0 @lhs.pIdC 0) "", -- key NoIDP [chr 174] `withFontFam` "symbol" , @exp.pres , sep (mkIDP @idP1 @lhs.pIdC 1) ";" ] { 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 :: Presentation_ -> PathDoc -> Presentation_ 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 idP0 idP1 idP2 idP3 expanded autoLayout ident exp) = \(DocumentLevel d path cl) -> let (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD pth) (Clip_Decl (Decl idP0 idP1 idP2 idP3 True autoLayout ident exp)) ) in (DocumentLevel d' path cl) toggleExpanded :: [Int] -> Decl -> UpdateDoc Document clip toggleExpanded pth (Decl idP0 idP1 idP2 idP3 expanded autoLayout ident exp) = \(DocumentLevel d path cl) -> let (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD pth) (Clip_Decl (Decl idP0 idP1 idP2 idP3 (not expanded) autoLayout ident exp)) ) in (DocumentLevel d' path cl) toggleAutoLayout :: [Int] -> Decl -> UpdateDoc Document clip toggleAutoLayout pth (Decl idP0 idP1 idP2 idP3 expanded autoLayout ident exp) = \(DocumentLevel d path cl) -> let (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD pth) (Clip_Decl (Decl idP0 idP1 idP2 idP3 expanded (not autoLayout) ident exp)) ) in (DocumentLevel d' path cl) -- use attributes! strFromIdent (Ident _ _ str) = str strFromIdent _ = "" idP0FromIdent (Ident idp0 _ str) = idp0 idP0FromIdent _ = NoIDP box xp = overlayReverse [xp, poly [(0,0),(1,0),(1,1),(0,1),(0,0)] Transparent] op :: IDP -> String -> Presentation_ op idc str = token idc str `withColor` opCol key :: IDP -> String -> Presentation_ key idc str = token idc str `withColor` keyCol sep :: IDP -> String -> Presentation_ sep idc str = token idc str `withColor` sepCol cons :: IDP -> String -> Presentation_ cons idc str = token idc str `withColor` consCol typeD :: IDP -> String -> Presentation_ typeD idc str = bold $ presType str `withColor` typeDCol -- idc is never used for type decls. token idp str = TokenP idp (UserTk 0 (KeyTk str) str Nothing idp) opCol = black keyCol = blue sepCol = brown consCol = black typeDCol = purple --darkViolet 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 (Node_Exp 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 -------------------------------------------------------------- SEM EnrichedDoc [ | | ] | RootEnr -- lhs.whitespaceMap = @lhs.whitespaceMap -- no auto layout {- Simple whitespace calculation that only puts newline after generated type sig -- can be used instead of complex calculation below (which allows auto-layout) SEM Decl | Decl lhs.whitespaceMap = if @idP2 == NoIDP && @lhs.level == 0 then debug Prs ("Inserting:"++show (mkIDP @idP2 @lhs.pIdC 2)) $ updateLayout (mkIDP @idP2 @lhs.pIdC 2) (1,0) @lhs.whitespaceMap else @lhs.whitespaceMap -} { updateLayoutList :: [(IDP,Whitespace)] -> WhitespaceMap -> WhitespaceMap updateLayoutList xs wm = foldr (uncurry updateLayout) wm xs updateLayout :: IDP -> Whitespace -> WhitespaceMap -> WhitespaceMap updateLayout idp ws whitespaceMap = Map.insertWith (updateWhitespace ws) idp freshLayout whitespaceMap where updateWhitespace ws _ layout = layout { whitespace = ws } freshLayout = TokenLayout ws (Nothing, Nothing) (Nothing, Nothing) } {- 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 List_Decl ConsList_Decl Decl Ident Exp List_Exp ConsList_Exp List_Alt ConsList_Alt Alt [ newlines, spaces : Int | col : Int | ] SEM RootE | RootE --lhs.whitespaceMap = @lhs.whitespaceMap -- no auto layout decls.whitespaceMap = @lhs.whitespaceMap decls.col = 0 decls.newlines = 1 decls.spaces = 0 lhs.whitespaceMap = @decls.whitespaceMap -- 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). ATTR Decl [ isLast : Bool | | ] SEM ConsList_Decl [ | | isNil : Bool ] | Nil_Decl lhs.isNil = True | Cons_Decl lhs.isNil = False head.isLast = @tail.isNil SEM Decl -- nested decls do produce auto layout, so top level decl can determine whether to use it. -- condition seems weird, why take autolayout if level /=0? because at top-level -- lhs.whitespaceMap is used anyway when autolayout == False? -- | Decl lhs.whitespaceMap = let lm = if @autoLayout || @lhs.level /= 0 then @exp.whitespaceMap else @lhs.whitespaceMap in if @idP2 /= NoIDP || @lhs.level /= 0 then lm else debug Prs ("Inserting:"++show (mkIDP @idP2 @lhs.pIdC 2)) $ updateLayout (mkIDP @idP2 @lhs.pIdC 2) (1,0) lm ident.whitespaceMap = updateLayoutList ([(@idP0, (0,1)) ] ++ -- on top level, don't change layout after ';' if @lhs.level /= 0 then [ (@idP1, (@lhs.newlines, @lhs.spaces - -- trailing spaces of last decl are 4 less because of "in " if @lhs.isLast then 4 else 0 )) ] else [] ) @lhs.whitespaceMap ident.col = @lhs.col ident.newlines = 0 ident.spaces = 1 exp.col = @ident.col+2+1 -- " = " exp.newlines = 0 exp.spaces = 0 lhs.col = @lhs.col SEM Ident [ | | ] | Ident lhs.whitespaceMap = updateLayout @idP0 (@lhs.newlines,@lhs.spaces) @lhs.whitespaceMap lhs.col = @lhs.col+ length @string -- put layout for tokens in front of whitespaceMap 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.whitespaceMap = updateLayout @idP0 (0,1) @lhs.whitespaceMap exp1.col = @lhs.col exp2.col = @exp1.col + 3 exp1.newlines = 0 exp1.spaces = 1 -- exp2 newlines and spaces are copied inherited lhs.col = @exp2.col | TimesExp exp1.whitespaceMap = updateLayout @idP0 (0,1) @lhs.whitespaceMap exp1.col = @lhs.col exp2.col = @exp1.col + 3 exp1.newlines = 0 exp1.spaces = 1 lhs.col = @exp2.col | DivExp exp1.whitespaceMap = updateLayout @idP0 (@lhs.newlines,@lhs.spaces) @lhs.whitespaceMap exp1.col = 0 exp1.newlines = 0 exp1.spaces = 0 exp2.col = 0 exp2.newlines = 0 exp2.spaces = 0 lhs.col = @lhs.col + (@exp1.col `max` @exp2.col) -- does not take into account smaller font | PowerExp exp1.whitespaceMap = updateLayout @idP0 (@lhs.newlines,@lhs.spaces) @lhs.whitespaceMap exp1.col = 0 exp1.newlines = 0 exp1.spaces = 0 exp2.col = 0 exp2.newlines = 0 exp2.spaces = 0 lhs.col = @lhs.col + @exp1.col + @exp2.col -- does not take into account smaller font | IntExp lhs.whitespaceMap = updateLayout @idP0 (@lhs.newlines,@lhs.spaces) @lhs.whitespaceMap lhs.col = @lhs.col+length (show @int) | BoolExp lhs.whitespaceMap = updateLayout @idP0 (@lhs.newlines,@lhs.spaces) @lhs.whitespaceMap | LamExp ident.whitespaceMap = updateLayoutList [ (@idP0, (0,0)) , (@idP1, (0,1)) ] @lhs.whitespaceMap ident.col = @lhs.col + 1 -- "\" ident.newlines = 0 ident.spaces = 1 exp.col = @ident.col + 3 -- "\arrow" 4 --" -> " exp.newlines = 0 exp.spaces = 0 lhs.col = @exp.col | AppExp exp1.whitespaceMap = @lhs.whitespaceMap exp2.col = @exp1.col+1 --" " exp1.newlines = @lhs.newlines exp1.spaces = @lhs.spaces lhs.col = @exp2.col | CaseExp exp.whitespaceMap = updateLayoutList [ (@idP0, (@lhs.newlines,@lhs.spaces)) , (@idP1, (0,1)) ] @lhs.whitespaceMap 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.whitespaceMap = updateLayoutList [ (@idP0, (0,1)) , (@idP1, (0,2))] @lhs.whitespaceMap decls.col = @lhs.col + 3+1 -- "let " exp.col = @lhs.col + 3+1 -- "in " decls.newlines = 1 decls.spaces = @lhs.col + 3 + 1 exp.newlines = @lhs.newlines exp.spaces = @lhs.spaces -- | IdentExp has no tokens, so attrs are chained -- | IfExp exp1.whitespaceMap = updateLayoutList [ (@idP0, (0,1)) , (@idP1, (0, 1)) , (@idP2, (0, 1)) ] @lhs.whitespaceMap exp1.col = @lhs.col + 2+1 -- "if " exp2.col = @lhs.col + 4+1 -- "then " exp3.col = @lhs.col + 4+1 -- "else " exp1.newlines = 1 exp1.spaces = @lhs.col exp2.newlines = 1 exp2.spaces = @lhs.col exp3.newlines = @lhs.newlines exp3.spaces = @lhs.spaces | ParenExp exp.whitespaceMap = updateLayoutList [ (@idP0, (0,0)) , (@idP1, (@lhs.newlines,@lhs.spaces)) ] @lhs.whitespaceMap exp.col = @lhs.col + 1 -- "(" exp.newlines = 0 exp.spaces = 0 lhs.col = @exp.col + 1 --")" | ListExp exps.whitespaceMap = updateLayoutList ([ (@idP0, (0,1)) , (@idP1, (@lhs.newlines,@lhs.spaces)) ] ++ [ (idp, (0,1)) | idp <- @ids] ) @lhs.whitespaceMap exps.col = @lhs.col + 1+1 -- "[ " exps.newlines = 0 exps.spaces = 1 lhs.col = @exps.col + 1+1 --" ]" | ProductExp exps.whitespaceMap = updateLayoutList [ (@idP0, (0,1)) , (@idP1, (@lhs.newlines,@lhs.spaces)) ] @lhs.whitespaceMap exps.col = @lhs.col + 1+1 -- "( " exps.newlines = 0 exps.spaces = 1 lhs.col = @exps.col + 1+1 --" )" SEM ConsList_Exp -- all exps get same (newlines, spaces) | Cons_Exp tail.col = @head.col + 2 --", " -- alts compute a maximum lefthand side length, which is sent back down at the case node. SEM Alt [ totalMaxLHSLength : Int | | lhsLength : Int ] | Alt ident.whitespaceMap = updateLayoutList [(@idP0, (0,@lhs.totalMaxLHSLength - @lhsLength+1)), (@idP1, (0,0))] @lhs.whitespaceMap 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 SEM Item | HeliumItem exp.col = 0 lhs.whitespaceMap = @lhs.whitespaceMap -- no auto layout in slides -- doesn't work for nested let's anyway -------------------------------------------------------------- -- -- 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 : {Map String (PathDoc, String)} | varsInScopeAtFocus : {Map String (PathDoc, String)} | ] -- path needs to be accessible from parent, or is that just now? SEM RootE | RootE --loc.varsInScope = mapInsertList @decls.declaredVars (unitFM "" (NoPathD, "")) loc.varsInScope = Map.fromList @decls.declaredVars SEM Exp | LetExp loc.varsInScope = mapInsertList @decls.declaredVars @lhs.varsInScope | LamExp exp.varsInScope = Map.insert (strFromIdent @ident.self) (PathD $ (@lhs.path++[0]), @exp.type) @lhs.varsInScope 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 RootE | RootE decls.varsInScopeAtFocus = Map.empty -- 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 RootE | RootE 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 | 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 | IntExp lhs.val = IntVal @int | LamExp lhs.val = -- @exp :: Bindings -> FocusDoc -> Int -> [Int] -> (Int,Presentation, Exp, Value) LamVal (\arg -> let syn = wrap_Exp @exp Inh_Exp {env_Inh_Exp = ((@ident.str, arg): @lhs.env)} in val_Syn_Exp syn) -- dirty hack because AG does not allow this easily (maybe new version with higher-order stuff makes it easier) | 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} -- case is useless, since there are no constructors yet. | LetExp lhs.val = -- @exp :: Int -> Bindings -> FocusDoc -> Int -> [Int] -> (Int,Presentation, Exp, Value) let syn = wrap_Exp @exp Inh_Exp {env_Inh_Exp = (@decls.dcls ++ @lhs.env)} in val_Syn_Exp syn -- dirty hack because AG does not allow this easily (maybe new version with higher-order stuff makes it easier) | 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 loc.pres = parsing $ row [key (mkIDP @idP0 @lhs.pIdC 0) "Chess: ", @board.pres] SEM Board [ | | ] | Board loc.pres = 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 loc.pres = 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 loc.pres = structural $ Chess.piece @self @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 loc.pres = structural $ Chess.piece @self @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 loc.pres = structural $ Chess.piece @self @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 loc.pres = structural $ Chess.piece @self @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 loc.pres = structural $ Chess.piece @self @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 loc.pres = structural $ Chess.piece @self @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 loc.pres = structural $ Chess.piece @self @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_ ] SEM List_Decl | List_Decl lhs.idsPres = loc (Node_List_Decl @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ @elts.idsPres | HoleList_Decl lhs.idsPres = presHole @lhs.focusD "Decls" (Node_HoleList_Decl @self @lhs.path) @lhs.path | ParseErrList_Decl lhs.idsPres = parsing $ empty SEM ConsList_Decl | Cons_Decl lhs.idsPres = row [ @head.idsPres, text " ", @tail.idsPres ] | Nil_Decl lhs.idsPres = parsing $ empty SEM Decl | Decl lhs.idsPres = loc (Node_Decl @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row [ text "'", @ident.idsPres, text "';" ] | BoardDecl lhs.idsPres = loc (Node_BoardDecl @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row [ text "board;" ] | PPPresentationDecl lhs.idsPres = loc (Node_PPPresentationDecl @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row [ text "slides;" ] | HoleDecl lhs.idsPres = presHole @lhs.focusD "Decl" (Node_HoleDecl @self @lhs.path) @lhs.path | ParseErrDecl lhs.idsPres = presParseErr (Node_ParseErrDecl @self @lhs.path) @error SEM Ident | Ident lhs.idsPres = loc (Node_Ident @self @lhs.path) $ parsing $ presentFocus @lhs.focusD @lhs.path $ row [ text @string ] | HoleIdent lhs.idsPres = presHole @lhs.focusD "Ident" (Node_HoleIdent @self @lhs.path) @lhs.path | ParseErrIdent lhs.idsPres = presParseErr (Node_ParseErrIdent @self @lhs.path) @error SEM RootE -- don't understand why this is necessary, it should not be used. However, without ag eval crashes | RootE {- idListDecls.col = 0 -- auto layout idListDecls.newlines = 0 -- idListDecls.spaces = 0 -- -} idListDecls.level = 0 -- not right idListDecls.errs = [] idListDecls.env = [] idListDecls.varsInScopeAtFocus = Map.empty 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.whitespaceMap = Map.empty exp.errs = [] exp.typeEnv = [] exp.topLevelEnv = [] exp.env = [] ATTR PPPresentation List_Slide ConsList_Slide Slide ItemList ListType List_Item ConsList_Item Item [ varsInScope : {Map String (PathDoc, String)} | varsInScopeAtFocus : {Map String (PathDoc, String)} | ] ATTR PPPresentation List_Slide ConsList_Slide Slide ItemList ListType List_Item ConsList_Item Item [ ranges : {([PathDoc],[PathDoc],[PathDoc])} | | ] SEM Decl | PPPresentationDecl loc.pres = parsing $ row [ key (mkIDP @idP0 @lhs.pIdC 0) "Slides: ", @pPPresentation.pres ] SEM PPPresentation | PPPresentation loc.pres = structural $ col $ [ row [-- text "View type: ", if @viewType then (box $ text $ "XML view") `addPopupItems` [("Change to presentation view", docUpd $ toggleViewType @lhs.path @self)] else (box $ text $"Presentation view") `addPopupItems` [("Change to XML view", docUpd $ toggleViewType @lhs.path @self)] ] , vSpace 10 ] ++ if @viewType then [ text "" , @slides.pres , text "" ] else [ @slides.pres2 ] -- then (box $ text $ "Edit view") `addPopupItems` [("Change to presentation view",docUpd $ toggleViewType @lhs.path @self)] -- else (box $ text $"Presentation view") `addPopupItems` [("Change to edit view",docUpd $ toggleViewType @lhs.path @self)] -- [ row [ text "pres ",key NoIDP "=",text " Presentation ", text " $"] -- , row [ text " ", @slides.pres] SEM List_Slide | List_Slide loc.pres = structural $ presentList @elts.press { 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 loc.pres = structural $ col [ row [ text "", row [ text "", parsing $ text @title `withColor` darkViolet , text "" ]] , row [ text " ", @itemList.pres ] , text "" ] SEM ItemList | ItemList loc.pres = structural $ col [ row [ text ""] , @items.pres , text "" ] SEM List_Item | List_Item loc.pres = structural $ presentList @elts.press SEM ListType | Bullet loc.pres = structural $ text "Bullet" | Number loc.pres = structural $ text "Number" | Alpha loc.pres = structural $ text "Alpha" SEM Item | StringItem loc.pres = structural $ row [ text "", parsing $ text @string `withColor` darkViolet, text "" ] | HeliumItem loc.pres = structural $ col [ text "" , row [text " ", @exp.pres] , text "" ] | ListItem loc.pres = structural $ col [ text "" , row [text " ", @itemList.pres] , text "" ] { -- many Document refs may be doc when editPasteD is fixed toggleViewType :: [Int] -> PPPresentation -> UpdateDoc Document clip toggleViewType pth (PPPresentation viewtp slides) = \(DocumentLevel d path cl) -> let (DocumentLevel d' _ _) = editPasteD (DocumentLevel d (PathD pth) (Clip_PPPresentation (PPPresentation (not viewtp) slides)) ) in (DocumentLevel d' path cl) slide title body = overlay [ move 0 30 $ col [ hAlignCenter $ parsing $ title `withColor` white `withFont'` ("cmr10", 20) , row [ hSpace 20, body `withbgColor` myBlue ] ] `withHStretch` True , rect 500 300 Solid `withfColor` myBlue `withColor` myBlue ] `withColor` yellow `withbgColor` myBlue `withFont'` ("Arial", 15) where myBlue = (0,0,192) } ATTR Slide ItemList {- ListType -} Item [ || pres2 : Presentation_ ] ATTR List_Slide ConsList_Slide List_Item ConsList_Item [ || press2 : {[Presentation_]} ] -- seems like parse err and hole are wrong SEM List_Slide [ || pres2 : Presentation_ ] | List_Slide lhs.pres2 = loc (Node_List_Slide @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col $ intersperse (col [vSpace 4, hLine, vSpace 4]) @elts.press2 | ParseErrList_Slide lhs.pres2 = presParseErr (Node_ParseErrList_Slide @self @lhs.path) @error | HoleList_Slide lhs.pres2 = presHole @lhs.focusD "Slides" (Node_HoleList_Slide @self @lhs.path) @lhs.path SEM Slide | Slide lhs.pres2 = loc (Node_Slide @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ slide (text @title) @itemList.pres2 `withLocalPopupMenuItems` (mkPopupItemsFromDocUpdates $ menuD (PathD @lhs.path) @lhs.doc) -- Tricky: need to put an invisible structural presentation of listTypeNode, because -- makeStructuralListType expects it SEM ItemList | ItemList lhs.pres2 = loc (Node_ItemList @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_ typeLoc : {Presentation_ -> Presentation_}] | Bullet lhs.pres2 = loc (Node_Bullet @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ empty lhs.typeLoc = \pres -> loc (Node_Bullet @self @lhs.path) $ pres `withLocalPopupMenuItems` (mkPopupItemsFromDocUpdates $ menuD (PathD @lhs.path) @lhs.doc) | Number lhs.pres2 = loc (Node_Number @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ empty lhs.typeLoc = \pres -> loc (Node_Number @self @lhs.path) $ pres `withLocalPopupMenuItems` (mkPopupItemsFromDocUpdates $ menuD (PathD @lhs.path) @lhs.doc) | Alpha lhs.pres2 = loc (Node_Alpha @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ empty lhs.typeLoc = \pres -> loc (Node_Alpha @self @lhs.path) $ pres `withLocalPopupMenuItems` (mkPopupItemsFromDocUpdates $ menuD (PathD @lhs.path) @lhs.doc) | ParseErrListType lhs.typeLoc = id | HoleListType lhs.typeLoc = id -- seems like parse err and hole are wrong SEM List_Item [ || pres2 : Presentation_ ] | List_Item lhs.pres2 = loc (Node_List_Item @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ col @elts.press2 | ParseErrList_Item lhs.pres2 = presParseErr (Node_ParseErrList_Item @self @lhs.path) @error | HoleList_Item lhs.pres2 = presHole @lhs.focusD "Items" (Node_HoleList_Item @self @lhs.path) @lhs.path SEM Item [ listType : ListType typeLoc : {Presentation_ -> Presentation_} || ] | StringItem lhs.pres2 = loc (Node_StringItem @self @lhs.path) $ structural $ presentFocus @lhs.focusD @lhs.path $ row [itemStart @lhs.ix @lhs.listType @lhs.typeLoc, parsing $ text @string] | HeliumItem lhs.pres2 = loc (Node_HeliumItem @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 (Node_ListItem @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_ -> Presentation_} || ] SEM ConsList_Item [ listType : ListType typeLoc : {Presentation_ -> Presentation_} || ] | 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 = [] | ParseErrList_Slide lhs.press2 = [] SEM Slide | HoleSlide lhs.pres2 = presHole @lhs.focusD "Slide" (Node_HoleSlide @self @lhs.path) @lhs.path | ParseErrSlide lhs.pres2 = presParseErr (Node_ParseErrSlide @self @lhs.path) @error SEM ItemList | HoleItemList lhs.pres2 = presHole @lhs.focusD "ItemList" (Node_HoleItemList @self @lhs.path) @lhs.path | ParseErrItemList lhs.pres2 = presParseErr (Node_ParseErrItemList @self @lhs.path) @error SEM ListType | HoleListType lhs.pres2 = presHole @lhs.focusD "ListType" (Node_HoleListType @self @lhs.path) @lhs.path | ParseErrListType lhs.pres2 = presParseErr (Node_ParseErrListType @self @lhs.path) @error SEM List_Item | HoleList_Item lhs.press2 = [] | ParseErrList_Item lhs.press2 = [] SEM Item | HoleItem lhs.pres2 = presHole @lhs.focusD "Item" (Node_HoleItem @self @lhs.path) @lhs.path | ParseErrItem lhs.pres2 = presParseErr (Node_ParseErrItem @self @lhs.path) @error