packages feed

CLASE (empty) → 2008.9.23

raw patch · 13 files changed

+1657/−0 lines, 13 filesdep +basedep +containersdep +filepathsetup-changed

Dependencies added: base, containers, filepath, mtl, parsec, template-haskell

Files

+ CLASE.cabal view
@@ -0,0 +1,39 @@+Name:           CLASE+Version:        2008.9.23+Cabal-Version:  >= 1.2+License:        BSD3+Build-Type:     Simple+License-File:   LICENSE+Author:         Tristan Allwood+Maintainer:     clase@zonetora.co.uk+Homepage:       http://www.zonetora.co.uk/clase/+Stability:      alpha+Synopsis:       Cursor Library for A Structured Editor+Description:    A library to aid the development of structured editors that+                require a zipper-like interface to the language being edited.+Category:       Data+Tested-With:    GHC ==6.8.3++Library+  Build-Depends:    base,+                    parsec >= 2.1.0.1,+                    containers >= 0.1.0.2,+                    template-haskell,+                    filepath >= 1.1.0.0,+                    mtl >= 1.1.0.1++  Exposed-Modules:  +    Data.Cursor.CLASE.Language,+    Data.Cursor.CLASE.Bound,+    Data.Cursor.CLASE.Persistence,+    Data.Cursor.CLASE.Traversal,+    Data.Cursor.CLASE.Util,+    Data.Cursor.CLASE.Gen.Language,+    Data.Cursor.CLASE.Gen.Adapters,+    Data.Cursor.CLASE.Gen.Persistence++  Other-Modules:+    Data.Cursor.CLASE.Gen.Util,+    Data.Cursor.CLASE.Gen.PrintM++  Extensions:
+ Data/Cursor/CLASE/Bound.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE GADTs, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+module Data.Cursor.CLASE.Bound(+ Bound(..),+ inBindingScope+) where++import Data.Cursor.CLASE.Language++class (Language l) => Bound l t where+  bindingHook :: Context l from to -> t -> t+++inBindingScope :: (Bound l t) => (a -> t) -> Cursor l x a -> t+inBindingScope fn (Cursor it ctx _) = foldUp (fn it) ctx++foldUp :: (Bound l t) => t -> Path l (Context l) a b -> t+foldUp t Stop = t+foldUp t (Step ctx nxt) = foldUp (bindingHook ctx t) nxt
+ Data/Cursor/CLASE/Gen/Adapters.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE TemplateHaskell, PatternSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+module Data.Cursor.CLASE.Gen.Adapters(adapterGen) where++import Data.List+import Data.Maybe+import Data.Cursor.CLASE.Gen.Util+import Language.Haskell.TH+import Data.Cursor.CLASE.Gen.PrintM+import System.FilePath+import System.IO++import qualified Data.Map as Map+import Data.Map (Map)++adapterGen :: [String] -> Name -> [Name] -> String -> Q [Dec]+adapterGen moduleNames rootName acceptableNames gendLanguage = do+  nameMap <- buildMap acceptableNames++  fileOut <- runIO $ openFile (joinPath moduleNames <.> "hs") WriteMode++  let rootNameModule = nameModule rootName+  let moduleName = concat . intersperse "." $ moduleNames+++  runIO . runPrint fileOut $ do+    printHeader moduleName (fromMaybe "" rootNameModule) gendLanguage++    printClasses rootName nameMap++    printVisitCursor rootName++    printInstanceHeader rootName acceptableNames++    let contextCtrs = buildContextCtrs nameMap++    printVisitStep rootName nameMap contextCtrs++    printVisitPartial rootName acceptableNames contextCtrs++    printCursor+  runIO $ hFlush fileOut+  runIO $ hClose fileOut++  return [] ++printHeader :: String -> String -> String -> PrintM ()+printHeader modName rootModName rootLangModName = do+  printLn . unlines $ [ "{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,"+    , "             UndecidableInstances, RankNTypes, GADTs, TypeFamilies #-}"+    , "{-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-name-shadowing #-}"++    , "module " ++ modName ++ " where"+    , "{- AUTOGENERATED (See Data.Cursor.CLASE.Gen.Adapters) -}"+    , ""+    , "import " ++ rootModName +    , "import " ++ rootLangModName+    , "import Data.Cursor.CLASE.Language"+    , "import Data.Cursor.CLASE.Bound"+    , "import Data.Cursor.CLASE.Traversal"+    ]++printClasses :: Name -> Map Name DataType -> PrintM ()+printClasses rootName = mapM_ (uncurry printClass) . Map.toList+  where+    rootNameS = nameBase rootName++    printClass :: Name -> DataType -> PrintM ()+    printClass clNam (DataType _ ctrs) = do+      printLn $ "class " ++ rootNameS ++ "TraversalAdapter" ++ clNamS ++ " t where"+      mapM_ printCases ctrs+      printLn ""+      where+        clNamS = nameBase clNam++        printCases :: Constructor -> PrintM ()+        printCases ctr = do+          printLn $ "  visit" ++ ctrNameS ++ " :: " ++ tipe+            where+              tipe = concat . intersperse " -> " $ clNamS : +                (map (const "t") . filter isNavigable . ctrKids $ ctr) ++ ["t"]+              ctrNameS = nameBase .ctrName $ ctr ++    printClass _ _ = error "printClass for wraps list not supported [yet]!"+  +   ++printVisitCursor :: Name -> PrintM ()+printVisitCursor nam = do+  printLn . unlines $ +    [ "class " ++ (nameBase nam) ++ "TraversalAdapterCursor t where"+    , "  visitCursor :: " ++ (nameBase nam) ++ " -> t -> t"+    ]++printInstanceHeader :: Name -> [Name] -> PrintM ()+printInstanceHeader rootName okNames = do+  printLn $ "instance (" ++ preconds +++            "\n          " ++ rootNameS ++ "TraversalAdapterCursor t," +++            "\n          Bound " ++ rootNameS ++ " t) => Traversal " ++ rootNameS ++ " t where\n"+  where+    preconds = concat . intersperse "\n          " . +                        map (\n -> rootNameS ++ "TraversalAdapter" ++ n ++ " t,") $ okNameS++    rootNameS = nameBase rootName+    okNameS = map nameBase okNames+  ++printVisitStep :: Name -> Map Name DataType -> [ContextCtr] -> PrintM ()+printVisitStep rootName nameMap ctxCtrs = do+  printLn . unlines $ +    [ "  visitStep it recurse = case reify it of"+    , "    TW x -> visitStep' x it recurse"+    , "    where"+    , "      visitStep' :: (" ++ preconds ++ ") =>"+    , "                    TypeRepI a -> a -> (forall b . Reify " ++ rootNameS ++ " b => Movement " ++ rootNameS ++ " Down a b -> t) -> t"+    ]+  mapM_ (uncurry printVisitStepCase) (Map.toList nameMap)+  printLn ""+  where+    preconds = concat . intersperse ",\n                     " . +                        map (\n -> rootNameS ++ "TraversalAdapter" ++ n ++ " t") .+                        map nameBase . +                        Map.keys $ nameMap+    rootNameS = nameBase rootName++    printVisitStepCase :: Name -> DataType -> PrintM ()+    printVisitStepCase tipe (DataType _ ctrs) = do+      printLn $ "      visitStep' " ++ tipeS ++ "T it recurse = case it of"+      mapM_ printVisitStepCtrCase ctrs+        where+          tipeS = nameBase tipe++          printVisitStepCtrCase (Ctr ctrName kids) = do+            printLn $ "        " ++ ctrNameS ++ " " ++ underscorePattern ++ " -> visit" ++ ctrNameS ++ " it " ++ recursePatterns+              where+                ctrNameS = nameBase ctrName+                underscorePattern = unwords $ replicate (length kids) "_" +                recursePatterns =  unwords . map (\k -> "(recurse (MW " ++ (downCtrName k) ++ "))") . filter ( (== ctrName) . ctxCtrCtrTo) $ ctxCtrs+                --recursePatterns = unwords . map (\k -> "(recurse (MW M" ++ ctrNameS ++ "To" ++ (nameBase . childType $ k) ++ "))") . filter isNavigable $ kids+  +    printVisitStepCase _ _ = error "Can't prinit visitStep case for list dts yet"+++printVisitPartial :: Name -> [Name] -> [ContextCtr] -> PrintM ()+printVisitPartial rootName okNames ctxCtrs = do+  printLn . unlines $ +    [ "  visitPartial (CW ctx) = visitPartial' ctx"+    , "    where"+    , "      visitPartial' :: (" ++ preconds ++ ") =>"+    , "          ContextI a b -> b -> t -> (forall c . Reify " ++ rootNameS ++ " c => Movement " ++ rootNameS ++ " Down b c -> t) -> t"+    , "      visitPartial' ctx it hole recurse = case ctx of"+    ]+  mapM_ printCtrCase ctxCtrs+  printLn ""+  where+    rootNameS :: String+    rootNameS = nameBase rootName++    preconds :: String+    preconds = concat . intersperse ",\n                        " . +                        map (\n -> rootNameS ++ "TraversalAdapter" ++ n ++ " t") $ okNameS+    okNameS = map nameBase okNames++    printCtrCase :: ContextCtr -> PrintM ()+    printCtrCase cc = do+      printLn $ "          " ++ (ctxCtrName cc) ++ " " ++ underscores ++ " -> visit" ++ (nameBase . ctxCtrCtrTo $ cc) ++ " it " ++ recursePatterns+        where+          underscores = unwords $ replicate (numCCArgs cc) "_"+          recursePatterns =  unwords . map (\k -> if k == cc +                                                    then "hole"+                                                    else "(recurse (MW " ++ (downCtrName k) ++ "))") . filter ( (==(ctxCtrCtrTo cc) ) . ctxCtrCtrTo) $ ctxCtrs++printCursor :: PrintM ()+printCursor = printLn $ "  cursor = visitCursor"
+ Data/Cursor/CLASE/Gen/Language.hs view
@@ -0,0 +1,466 @@+{-# LANGUAGE TemplateHaskell, PatternSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+module Data.Cursor.CLASE.Gen.Language(languageGen) where++import Control.Arrow+import Control.Monad+import Data.List+import Data.Map (Map)+import Data.Ord+import Data.Function+import Data.Maybe+import Data.Set (Set)+import Data.Cursor.CLASE.Gen.Util+import Data.Cursor.CLASE.Gen.PrintM+import System.FilePath+import Language.Haskell.TH+import qualified Data.Map as Map+import qualified Data.Set as Set+import System.IO++languageGen :: [String] -> Name -> [Name] -> Q [Dec]+languageGen moduleNames rootName acceptableNames = do+  nameMap <- buildMap acceptableNames+  +  fileOut <- runIO $ openFile (joinPath moduleNames <.> "hs") WriteMode++  let rootNameModule = nameModule rootName+  let moduleName = concat . intersperse "." $ moduleNames++  runIO . runPrint fileOut $ do+    printHeader moduleName rootNameModule (nameBase rootName)+    printLn ""++    printTypeRep nameMap+    printLn ""++    printReify rootName nameMap+    printLn ""++    let contextCtrs = buildContextCtrs nameMap++    printContext contextCtrs+    printLn ""++    printContextToMovement contextCtrs+    printLn ""++    printBuildOne contextCtrs+    printLn ""++    let leftRightNames = buildLeftRightNames nameMap+    printMovement contextCtrs leftRightNames+    printLn ""++    printInvertMovement contextCtrs leftRightNames+    printLn ""++    printMovementEq contextCtrs leftRightNames+    printLn ""++    printUnbuildOne contextCtrs leftRightNames+    printLn ""++    printReifyDirection contextCtrs+    printLn ""++    printDownMovements rootName contextCtrs+    printLn ""++    printGenericMoveLeft contextCtrs nameMap rootName+    printLn ""++    printGenericMoveRight contextCtrs nameMap rootName+    printLn ""++{-+    printToStringMovement contextCtrs leftRightNames+    printLn ""++    printContextReps contextCtrs+    printLn ""++    printMoveToRoot rootName+    printLn ""+-}++  runIO $ hFlush fileOut+  runIO $ hClose fileOut++  return []++printHeader :: String -> Maybe String -> String -> PrintM ()+printHeader modName mRootModName rootName = do+    printLn . unlines $ +     [ "{-# LANGUAGE GADTs, MultiParamTypeClasses, TypeFamilies, TypeOperators, ScopedTypeVariables, ExistentialQuantification #-}"+     , "{-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-overlapping-patterns #-}"+     , "{- AUTOGENERATED (See Data.Cursor.CLASE.Gen.Language) -}"+     , "module " ++ modName ++ "("+     , "   ContextI(..)"+     , "  ,TypeRepI(..)"+     , "  ,MovementI(..)"+     , "  ,Context(..)"+     , "  ,Movement(..)"+     , "  ,TypeRep(..)"+     , ") where"+     , "import Data.Maybe"+     , "import Data.Cursor.CLASE.Util"+     , "import Control.Arrow"+     , maybe "" ("import " ++) mRootModName+     , "import Data.Cursor.CLASE.Language"+     , ""+     , "instance Language " ++ rootName ++ " where"+     , "  data Context " ++ rootName ++ " from to = CW (ContextI from to)"+     , "  data Movement " ++ rootName ++ " d from to = MW (MovementI d from to)"+     , "  data TypeRep " ++ rootName ++ " t = TW (TypeRepI t)"+     , ""+     , "  buildOne (CW x) = buildOneI x"+     , "  unbuildOne (MW m) a = fmap (first CW) (unbuildOneI m a)"+     , "  invertMovement (MW x) = MW (invertMovementI x)"+     , "  movementEq (MW x) (MW y) = fmap snd $ movementEqI x y"+     , "  reifyDirection (MW x) = reifyDirectionI x"+     , "  contextToMovement (CW x) = MW (contextToMovementI x)"+     , "  downMoves (TW t) = map (\\(ExistsR x) -> ExistsR (MW x)) (downMovesI t)"+     , "  moveLeft  (MW m) = fmap (\\(ExistsR x) -> ExistsR (MW x)) (moveLeftI m)"+     , "  moveRight (MW m) = fmap (\\(ExistsR x) -> ExistsR (MW x)) (moveRightI m)"+     ]++buildLeftRightNames :: Map Name DataType -> Set Name+buildLeftRightNames = Set.fromList . map dtChildName . filter isWrapsList . Map.elems++printTypeRep :: Map Name DataType -> PrintM ()+printTypeRep nmap = do+  printLn "data TypeRepI a where"+  mapM_ printTypeRepLine (Map.keys nmap)+  where+    printTypeRepLine :: Name -> PrintM ()+    printTypeRepLine name = printLn $ "  " ++ (nameBase name) ++ "T :: TypeRepI " ++ (nameBase name)+++printReify :: Name -> Map Name DataType -> PrintM ()+printReify langName nmap = do+  mapM_ printReifyInstance (Map.keys nmap)+  where+    printReifyInstance :: Name -> PrintM ()+    printReifyInstance name = do+      printLn . unwords $ ["instance Reify", (nameBase langName),+                                            (nameBase name), "where"]+      printLn $ "  reify = const $ TW " ++ (nameBase name) ++ "T"+      printLn ""++printContext :: [ContextCtr] -> PrintM ()+printContext ctrs = do+  printLn "data ContextI a b where"+  mapM_ printContextCtr ctrs+  where+    printContextCtr :: ContextCtr -> PrintM ()+    printContextCtr cc = do+      printLn $ "  " ++ (ctxCtrName cc) ++ " :: " ++ tipes ++ " " ++ (typeFrom) ++ " " ++ (typeTo)+      where+        tipes = concat . intersperse " -> " $ (ctxArgs) ++ ["ContextI"]+        typeFrom = nameBase . ctxCtrTypeFrom $ cc+        typeTo = nameBase . ctxCtrTypeTo $ cc++        ctxListArgs+          | ctxCtrIsList cc = replicate 2 ("[" ++ typeFrom ++ "]")+          | otherwise = []+        ctxArgs = (ctxCtrArgsBefore cc) ++ ctxListArgs ++ (ctxCtrArgsAfter cc)++printContextToMovement :: [ContextCtr] -> PrintM ()+printContextToMovement ctrs = do+  printLn "contextToMovementI :: ContextI a b -> MovementI Up a b"+  mapM_ printContextToMovementLine ctrs+  where+    printContextToMovementLine :: ContextCtr -> PrintM ()+    printContextToMovementLine cc = do+      printLn $ "contextToMovementI " ++ pattern ++ " = " ++ movPattern+        where+          pattern = "(" ++ vars ++ ")"+          movPattern = "(MUp " ++ (downCtrName cc) ++ ")"+          vars = unwords $ [ctxCtrName cc] ++ replicate (numCCArgs cc) "_"++printBuildOne :: [ContextCtr] -> PrintM ()+printBuildOne ctrs = do+  printLn "buildOneI :: ContextI a b -> a -> b"+  mapM_ printBuildOneLine ctrs+  where+    printBuildOneLine :: ContextCtr -> PrintM ()+    printBuildOneLine cc = do+        printLn $ "buildOneI (" ++ pattern ++ ") h = " ++ (ctrPattern)+        where+          (pattern, ctrPattern) = buildPatterns cc++buildPatterns :: ContextCtr -> (String, String)+buildPatterns cc = (pattern, ctrPattern)+  where+    ctrPattern = unwords $ [nameBase . ctxCtrCtrTo $ cc] ++ argsPattern+    pattern = unwords $ [ctxCtrName cc] ++ varsPattern++    argsPattern = preVars ++ ctxArgs ++ postVars++    varsPattern = preVars ++ ctxVars ++ postVars+    (preVars, postVars) = second (take (length $ ctxCtrArgsAfter cc)) . +                            splitAt (length $ ctxCtrArgsBefore cc) $ vars+        +    ctxVars+      | ctxCtrIsList cc = ["l", "r"]+      | otherwise = []++    ctxArgs+      | ctxCtrIsList cc = ["((reverse l) ++ [h] ++ r)"]+      | otherwise = ["h"]++    vars :: [String] +    vars = map (('x':) . show) [(0::Integer)..]++buildApplyMovementPatterns :: ContextCtr -> (String, String)+buildApplyMovementPatterns cc = (ctxPattern, ctrPattern)+  where+    ctxPattern = unwords $ [ctxCtrName cc] ++ argsPattern+    ctrPattern = unwords $ [nameBase . ctxCtrCtrTo $ cc] ++ varsPattern++    argsPattern = preVars ++ ctxArgs ++ postVars+    varsPattern = preVars ++ ctxVars ++ postVars++    (preVars, postVars) = second (take (length $ ctxCtrArgsAfter cc)) . +                            splitAt (length $ ctxCtrArgsBefore cc) $ vars++    ctxVars+      | ctxCtrIsList cc = ["(h:es)"]+      | otherwise = ["h"]++    ctxArgs+      | ctxCtrIsList cc = ["[] es"]+      | otherwise = []+    +    vars :: [String]+    vars = map (('x':) . show) [(0::Integer)..]++buildLeftRightPatterns :: ContextCtr -> String -> String -> (String, String)+buildLeftRightPatterns cc lop rop = (ctxPatternBefore, ctxPatternAfter)+  where+    ctxPatternBefore = unwords $ [ctxCtrName cc] ++ beforePattern+    ctxPatternAfter  = unwords $ [ctxCtrName cc] ++ afterPattern++    beforePattern  = preVars ++ bArgs ++ postVars+    afterPattern   = preVars ++ aArgs ++ postVars++    (preVars, postVars) = second (take (length $ ctxCtrArgsAfter cc)) . +                            splitAt (length $ ctxCtrArgsBefore cc) $ vars++    bArgs+      | ctxCtrIsList cc = ["l", "r"]+      | otherwise = error "CtxCtr is not list!"++    aArgs+      | ctxCtrIsList cc = ["(" ++ lop ++ "l" ++")","(" ++ rop ++ "r" ++ ")"]+      | otherwise = error "CtxCtr is not list!"+    +    vars :: [String]+    vars = map (('x':) . show) [(0::Integer)..]++printMovement :: [ContextCtr]  -> Set Name -> PrintM ()+printMovement downRoutes _ {- TODO leftRights -} = do+  printLn "data MovementI d a b where"+  printLn "  MUp :: MovementI Down b a -> MovementI Up a b"+  mapM_ printDownMovement downRoutes+  --mapM_ printLeftRight (Set.toList leftRights)+  where+    printDownMovement :: ContextCtr -> PrintM ()+    printDownMovement cc = do+      printLn $ "  " ++ (downCtrName cc) ++ " :: MovementI Down " ++ fromS ++ " " ++ toS+      where+        fromS = nameBase . ctxCtrTypeTo $ cc+        toS   = nameBase . ctxCtrTypeFrom $ cc++{-+    printLeftRight :: Name -> PrintM ()+    printLeftRight name = do+      printLn $ "  M" ++ nameS ++ "Left" ++ rest+      printLn $ "  M" ++ nameS ++ "Right" ++ rest+      where+        nameS = nameBase name +        rest = " :: Movement " ++ nameS ++ " " ++ nameS+-}++printMovementEq :: [ContextCtr] -> Set Name -> PrintM ()+printMovementEq downRoutes leftRights = do+  printLn "movementEqI :: MovementI d x y -> MovementI d a b -> Maybe (TyEq x a, TyEq y b)"+  printLn "movementEqI (MUp a) (MUp b) = fmap (\\(x,y) -> (y,x)) $ movementEqI a b"+  mapM_ printDownMovementEq downRoutes+  mapM_ printLeftRightEq (Set.toList leftRights)+  printLn "movementEqI _ _ = Nothing"+  where+    printDownMovementEq :: ContextCtr -> PrintM ()+    printDownMovementEq cc = do+      printLn $ "movementEqI " ++ (downCtrName cc) ++ " " ++ (downCtrName cc) ++ " = Just (Eq, Eq)"++    printLeftRightEq :: Name -> PrintM ()+    printLeftRightEq name = do+      printLn $ "movementEqI " ++ (nameS ++ "Left") ++ " " ++ (nameS ++ "Left") ++ " = Just (Eq, Eq)"+      printLn $ "movementEqI " ++ (nameS ++ "Right") ++ " " ++ (nameS ++ "Right") ++ " = Just (Eq, Eq)"+      where+        nameS = "M" ++ nameBase name++printInvertMovement :: [ContextCtr] -> Set Name -> PrintM ()+printInvertMovement ctxCtrs leftRights = do+  printLn "invertMovementI :: MovementI d a b -> MovementI (Invert d) b a"+  printLn "invertMovementI (MUp dwn) = dwn"+  mapM_ printInvertDownRoute downPatterns+  mapM_ printInvertLeftRights (Set.toList leftRights)+  where+    downPatterns = map getDownCtr $ ctxCtrs++    getDownCtr :: ContextCtr -> String+    getDownCtr ctxCtr = sDownCtr+      where+        sDownCtr = liftM3 (\x y z -> "M" ++ x ++ "To" ++ y ++ z) +                             (nameBase . ctxCtrCtrTo) +                             (nameBase . ctxCtrTypeFrom) +                             (maybe "" show . ctxCtrOffset) ctxCtr ++    printInvertDownRoute :: String -> PrintM ()+    printInvertDownRoute sDownCtr = do+      printLn $ "invertMovementI " ++ sDownCtr ++ " = MUp (" ++ sDownCtr ++ ")"++    printInvertLeftRights :: Name -> PrintM ()+    printInvertLeftRights name = do+      printLn $ "invertMovementI " ++ (nameS ++ "Left = IMLeftRight " ++ nameS ++ "Right")+      printLn $ "invertMovementI " ++ (nameS ++ "Right = IMLeftRight " ++ nameS ++ "Left")+      where+        nameS = "M" ++ nameBase name++printUnbuildOne :: [ContextCtr] -> Set Name -> PrintM ()+printUnbuildOne contextCtrs leftRights = do+  printLn . unlines $ +    [ "unbuildOneI :: MovementI Down a b -> a -> Maybe (ContextI b a, b)",+      "unbuildOneI mov here = case mov of"]+  downMoveCases+  leftRightMoveCases+  printLn $ "  _ -> Nothing"+  where+    downMoveCases = mapM_ downMoveCase contextCtrs++    downMoveCase cc = do+      printLn $ "  " ++ (downCtrName cc) ++ " -> case here of"+      printLn $ "    (" ++ ctrPattern ++ ") -> " ++ "Just $ (" ++ ctrctxPattern ++ ", h)"+      printLn $ "    _ -> Nothing"+      where+        (ctrctxPattern, ctrPattern) = buildApplyMovementPatterns cc++    leftRightMoveCases = mapM_ leftRightMoveCase (Set.toList leftRights)++    leftRightMoveCase name = do+      printLn $ "      M" ++ nameBase name ++ "Left -> case step of"+      mapM_ leftMoveCase ctxCtrs+      printLn $ "        _ -> Nothing"+      printLn $ "      M" ++ nameBase name ++ "Right -> case step of"+      mapM_ rightMoveCase ctxCtrs+      printLn $ "        _ -> Nothing"+      where+        ctxCtrs = filter (liftM2 (&&) ((== name) . ctxCtrTypeFrom)+                                      (ctxCtrIsList)) contextCtrs++        leftMoveCase = moveCase "l" "tail " "it:"+        rightMoveCase = moveCase "r" "it:" "tail " ++        moveCase lr y z ctxCtr = do+          printLn $ "        (" ++ ctxCtrPatternBefore ++ ") -> if' (null " ++ lr ++ ") " ++ +                      "Nothing " +++                      "(Just $ ((head " ++ lr ++ "), " ++ ctxCtrPatternAfter ++ ")"+          where+            (ctxCtrPatternBefore, ctxCtrPatternAfter) = buildLeftRightPatterns ctxCtr y z+++printReifyDirection :: [ContextCtr] -> PrintM ()+printReifyDirection ctrs = do+  printLn $ "reifyDirectionI :: MovementI d a b -> DirectionT d"+  printLn $ "reifyDirectionI d = case d of"+  printLn $ "  (MUp _) -> UpT"+  mapM_ reifyDirectionDown ctrs+  where+    reifyDirectionDown :: ContextCtr -> PrintM ()+    reifyDirectionDown cc = printLn $ "  " ++ (downCtrName cc) ++ " -> DownT"++printGenericMoveLR :: String -> (ContextCtr -> [Child] -> Maybe (Child, Maybe Int)) -> [ContextCtr] -> Map Name DataType -> Name -> PrintM ()+printGenericMoveLR leftOrRight beforeOrAfterFn ctxcts dataMap rootName = do+  printLn $ "move" ++ leftOrRight ++ "I :: MovementI Down a x -> Maybe (ExistsR " ++ (nameBase rootName) ++  " (MovementI Down a))"+  printLn $ "move" ++ leftOrRight ++ "I mov = case mov of"+  mapM_ genericMove ctxcts+  printLn "    _ -> Nothing"+  where+    genericMove :: ContextCtr -> PrintM ()+    genericMove cc+      | isJust nextKid = do+          printLn $ "    " ++ (downCtrName cc) ++ " -> Just $ ExistsR " ++ notListMovement+      | otherwise = return ()+      where+        currName = ctxCtrCtrTo cc+        notListMovement = "M" ++ nameBase currName ++ "To" ++ nxtName+        --TODO listMovement = "M" ++ nameBase lstNxtName ++ leftOrRight+        --TODO lstNxtName = ctxCtrTypeFrom cc++        (Just ctr) = liftM (head . filter ( (== (ctxCtrCtrTo cc)) . ctrName ) . dtCtrs) . +                      Map.lookup (ctxCtrTypeTo cc) $ dataMap+        nextKid@(~(Just (child, moffset))) = beforeOrAfterFn cc (ctrKids ctr)+        nxtName = (nameBase . childType $ child) ++ (maybe "" show moffset)+      ++printGenericMoveRight :: [ContextCtr] -> Map Name DataType -> Name -> PrintM ()+printGenericMoveRight = printGenericMoveLR "Right" grabNextChild+  where+    grabNextChild :: ContextCtr -> [Child] -> Maybe (Child, Maybe Int)+    grabNextChild cc kids = liftM (id &&& calcOffset . childType) nextKid+      where+        calcOffset :: Name -> Maybe Int+        calcOffset nam+          | length allOtherKidsWithTheSameName > 1 = Just (length otherKidsWithTheSameNameBefore)+          | otherwise = Nothing+          where+            otherKidsWithTheSameNameBefore = filter (== nam) $ beforeKids ++ [currKid] +            allOtherKidsWithTheSameName    = otherKidsWithTheSameNameBefore ++ (filter (== nam) afterKids)+        nextKid = listToMaybe . filter isNavigable . drop 1 . drop (length beforeKids) $ kids+        beforeKids = ctxCtrTypesBefore cc+        afterKids  = ctxCtrTypesAfter cc+        currKid    = ctxCtrTypeFrom cc++printGenericMoveLeft :: [ContextCtr] -> Map Name DataType -> Name -> PrintM ()+printGenericMoveLeft = printGenericMoveLR "Left" grabNextChild+  where+    grabNextChild :: ContextCtr -> [Child] -> Maybe (Child, Maybe Int)+    grabNextChild cc kids = liftM (id &&& calcOffset . childType) nextKid+      where+        calcOffset :: Name -> Maybe Int+        calcOffset nam+          | length allOtherKidsWithTheSameName > 1 = Just (pred . length $ otherKidsWithTheSameNameBefore)+          | otherwise = Nothing+          where+            otherKidsWithTheSameNameBefore = filter (== nam) $ beforeKids++            allOtherKidsWithTheSameName    = otherKidsWithTheSameNameBefore ++ (filter (== nam) [currKid] ++ afterKids)++        nextKid    = listToMaybe . filter isNavigable . reverse . take (length beforeKids) $ kids+        beforeKids = ctxCtrTypesBefore cc+        afterKids  = ctxCtrTypesAfter cc+        currKid    = ctxCtrTypeFrom cc+++printDownMovements :: Name -> [ContextCtr] -> PrintM ()+printDownMovements langName ctxCtrs = do+  printLn $ "downMovesI :: TypeRepI a -> [ExistsR " ++ lNameS ++ " (MovementI Down a)]"+  printLn $ "downMovesI tr = case tr of "+  mapM_ (uncurry printTrCase) ctrsByTypeTo+  where+    lNameS = nameBase langName++    ctrsByTypeTo :: [(Name, [ContextCtr])]+    ctrsByTypeTo = map ((ctxCtrTypeTo . head) &&& id) . +                   groupBy ((==) `on` ctxCtrTypeTo) . +                   sortBy (comparing ctxCtrTypeTo) $ ctxCtrs++    printTrCase :: Name -> [ContextCtr] -> PrintM ()+    printTrCase trCase localCtrs = do+      printLn $ "  " ++ (nameBase trCase) ++ "T -> [" ++ dctrs ++ "]"+      where+        dctrs = concat . intersperse ", " . map (\x -> "(ExistsR " ++ x ++ ")") $ downCtrs+        downCtrs = map downCtrName localCtrs
+ Data/Cursor/CLASE/Gen/Persistence.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE TemplateHaskell, PatternSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+module Data.Cursor.CLASE.Gen.Persistence(persistenceGen) where++import Language.Haskell.TH+import Data.Cursor.CLASE.Gen.Util+import Data.Cursor.CLASE.Gen.PrintM+import System.IO+import System.FilePath+import Data.List+import Data.Maybe+import Control.Monad++persistenceGen :: [String] -> Name -> [Name] -> String -> Q [Dec]+persistenceGen moduleNames rootName acceptableNames gendLanguage = do+  nameMap <- buildMap acceptableNames++  let contextCtrs = buildContextCtrs nameMap++  fileOut <- runIO $ openFile (joinPath moduleNames <.> "hs") WriteMode++  let rootNameModule = nameModule rootName+  let moduleName = concat . intersperse "." $ moduleNames+++  runIO . runPrint fileOut $ do+    printHeader moduleName (fromMaybe "" rootNameModule) gendLanguage++    printClassHeader rootName++    printShowMovement contextCtrs++    printMovementUpDownLines++    printShowTypeRep rootName acceptableNames++    printTypeRepParser rootName acceptableNames++    printTypeRepEq rootName acceptableNames++    printUpMovesParser rootName acceptableNames contextCtrs++    printDownMovesParser rootName acceptableNames contextCtrs++    printFooter++  runIO $ do+    hFlush fileOut+    hClose fileOut++  return []++printHeader :: String -> String -> String -> PrintM ()+printHeader modName rootModName rootLangModName = do+  printLn . unlines $ +    [ "{-# LANGUAGE TypeFamilies #-}"+    , "{-# LANGUAGE GADTs #-}"+    , "{-# LANGUAGE UndecidableInstances #-}"+    , "{-# LANGUAGE FlexibleContexts #-}"+    , "{-# LANGUAGE ScopedTypeVariables #-}"+    , "{-# LANGUAGE PatternSignatures #-}"+    , "{-# LANGUAGE RankNTypes #-}"+    , "{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-incomplete-patterns #-}"+    , "module " ++ modName ++ " where"+    , "{- AUTOGENERATED (See Data.Cursor.CLASE.Gen.Persistence) -}"+    , ""+    , "import " ++ rootModName+    , "import " ++ rootLangModName+    , "import Data.Cursor.CLASE.Language"+    , "import Data.Cursor.CLASE.Persistence"+    , "import qualified Text.ParserCombinators.Parsec.Language as P"+    , "import qualified Text.ParserCombinators.Parsec.Token as P"+    , "import Text.ParserCombinators.Parsec"+    , "import Data.Cursor.CLASE.Util"+    ]++printClassHeader :: Name -> PrintM ()+printClassHeader rootName = do+  printLn $ "instance (PersistenceAdapter " ++ rootNameS ++ ") => Persistable " ++ rootNameS ++ " where"+  printLn ""+    where+      rootNameS = nameBase rootName++printShowMovement :: [ContextCtr] -> PrintM ()+printShowMovement ctxCtrs = do+  printLns $+    [ "  showMovement (MW x) = show' x"+    , "    where"+    , "      show' :: MovementI dir from to -> String"+    ]++  forM_ ctxCtrs printShowUpMovement+  forM_ ctxCtrs printShowDownMovement++  printLn ""+  where+    printShowUpMovement cc = printLn $+      "      show' (MUp " ++ smupctr ++ ") = \"" ++ mupctrshown ++ "\""+      where+        smupctr = downCtrName cc+        mupctrshown = upCtrNameShown cc++    printShowDownMovement cc = printLn $+      "      show' " ++ smupctr ++ " = \"" ++ smupctr ++ "\""+        where+          smupctr = downCtrName cc++printMovementUpDownLines :: PrintM ()+printMovementUpDownLines = do+  printLns $+    [ "  movementParser UpT = upMovesParser"+    , "  movementParser DownT = downMovesParser"+    , ""+    ]++printShowTypeRep :: Name -> [Name] -> PrintM ()+printShowTypeRep rootName acceptableNames = do+  let rootNameS = nameBase rootName+  printLns $+    [ "  showTypeRep = showTypeRep'"+    , "    where"+    , "      showTypeRep' :: forall a . TypeRep " ++ rootNameS ++ " a -> String"+    ]++  forM_ acceptableNames $ \name -> do+    let nameS = nameBase name+    printLn $ "      showTypeRep' (TW (" ++ nameS ++ "T :: TypeRepI a))  = \"" ++ nameS ++ "T\""++  printLn ""+++printTypeRepParser :: Name -> [Name] -> PrintM ()+printTypeRepParser rootName acceptableNames = do+  printLns $ +    [ "  typeRepParser = choice $ map (uncurry mkParser) itReps"+    , "    where"+    , "      itReps = [" ++ itRepLines ++ "]"+    , ""+    , "      mkParser :: String -> Exists (TypeRep " ++ rootNameS ++ ") -> Parser (Exists (TypeRep " ++ rootNameS ++ "))"+    , "      mkParser s v = try $ (symbol s >> return v)"+    , ""+    ]+  where+    rootNameS = nameBase rootName+    itRepLines = concat . intersperse ",\n                " $ itReps+    +    itReps = map (\name -> let nameS = (nameBase name ++ "T") in+                            "(\"" ++ nameS ++ "\", (Exists (TW " ++ nameS ++ ")))") +                 acceptableNames++printTypeRepEq :: Name -> [Name] -> PrintM ()+printTypeRepEq rootName acceptableNames = do+  printLns $+    [ "  typeRepEq = typeRepEq'"+    , "    where"+    , "      typeRepEq' :: forall a b . TypeRep " ++ rootNameS ++ " a -> TypeRep " ++ rootNameS ++ " b -> Maybe (TyEq a b)"+    ]++  printLns reps++  printLn "      typeRepEq' _ _ = Nothing"+  printLn ""+  where+    rootNameS = nameBase rootName+    reps = map (\name -> let nameS = (nameBase name ++ "T") in+            "      typeRepEq' (TW (" ++ nameS ++ " :: TypeRepI a)) (TW (" ++ +              nameS ++ " :: TypeRepI b)) = Just Eq") $ acceptableNames+      +printUpMovesParser :: Name -> [Name] -> [ContextCtr] -> PrintM ()+printUpMovesParser rootName acceptableNames ctxctrs = do+  printLns $+    [ "upMovesParser :: forall a . (Reify " ++ rootNameS ++ " a) => Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Up a)))"+    , "upMovesParser = upMovesParser' (reify (undefined :: a))"+    , "  where"+    , "    upMovesParser' :: forall a . (Reify " ++ rootNameS ++ " a) => TypeRep " ++ rootNameS ++ " a -> "+    , "      Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Up a)))"+    , "    upMovesParser' (TW x) = case x of"+    ]++  printLns $ cases+  +  printLn ""+  printLns $+    [ "    use options = choice $ map (uncurry mkParser) options"+    , "    c :: forall a b . (Reify " ++ rootNameS ++ " b) => " +++              "MovementI Up a b -> Parser (ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Up a))"+    ,  "    c = return . ExistsR . MW"+    ,  "    mkParser p s = try (symbol s >> p)"+    ]+  printLn ""++    where+      rootNameS = nameBase rootName+      cases = concatMap mkOptions acceptableNames+      +      mkOptions :: Name -> [String]+      mkOptions name +        | null options = [ "      (" ++ nameS ++ " :: TypeRepI a) -> use []"]+        | otherwise    = [ "      (" ++ nameS ++ " :: TypeRepI a) -> use options"+                         , "        where"+                         , "          options ="+                         , "            [ " ++ optionLines +                         , "            ]"+                         ]+        where+          nameS = nameBase name ++ "T"+          options = filter ((== name) . ctxCtrTypeFrom) ctxctrs+          optionLines = concat . intersperse "\n            , " . map mkOptionLine $ options++          mkOptionLine ctxCtr = "(c $ (MUp " ++ dcs ++ "), \"" ++ ucs ++ "\")"+            where+              dcs = downCtrName ctxCtr+              ucs = upCtrNameShown ctxCtr+++printDownMovesParser :: Name -> [Name] -> [ContextCtr] -> PrintM ()+printDownMovesParser rootName acceptableNames ctxCtrs = do+  printLns $+    [ "downMovesParser :: forall a . (Reify " ++ rootNameS ++ " a) => Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Down a)))"+    , "downMovesParser = downMovesParser' (reify (undefined :: a))"+    ,"  where"+    ,"    downMovesParser' :: forall a . (Reify " ++ rootNameS ++ " a) => TypeRep " ++ rootNameS ++ " a -> "+    ,"      Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Down a)))"+    ,"    downMovesParser' (TW x) = case x of"+    ]++  printLns $ cases++  printLn ""++  printLns $ +    [ "    use options = choice $ map (uncurry mkParser) options"+    , "    c :: forall a b . (Reify " ++ rootNameS ++ " b) => MovementI Down a b -> Parser (ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Down a))"+    , "    c = return . ExistsR . MW"+    , "    mkParser p s = try (symbol s >> p)"+    ]++  printLn ""++  where+    rootNameS = nameBase rootName ++    cases = concatMap mkOptions acceptableNames++    mkOptions :: Name -> [String]+    mkOptions name +      | null options = [ "      (" ++ nameS ++ " :: TypeRepI a) -> use []"]+      | otherwise    = [ "      (" ++ nameS ++ " :: TypeRepI a) -> use options"+                       , "        where"+                       , "          options ="+                       , "            [ " ++ optionLines+                       , "            ]"+                       ]+      where+        nameS = nameBase name ++ "T"++        options = filter ((== name) . ctxCtrTypeTo) ctxCtrs+        optionLines = concat . intersperse "\n            , " . map mkOptionLine $ options++        mkOptionLine ctxCtr = "(c $ " ++ dcs ++ ", \"" ++ dcs ++ "\")"+          where+            dcs = downCtrName ctxCtr++printFooter :: PrintM ()+printFooter = printLns $+  [ "haskellParser ::  P.TokenParser st"+  , "haskellParser = P.makeTokenParser P.haskellDef"+  , ""+  , "symbol ::  String -> CharParser st String"+  , "symbol = P.symbol haskellParser"+  ]
+ Data/Cursor/CLASE/Gen/PrintM.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.Cursor.CLASE.Gen.PrintM where++import Control.Monad+import Control.Monad.Reader+import System.IO++newtype PrintM a = PrintM { runPrintM :: ReaderT Handle IO a }+  deriving Monad++runPrint :: Handle -> PrintM a -> IO a+runPrint h = flip runReaderT h . runPrintM++printLn :: String -> PrintM ()+printLn s = PrintM $ (ask >>= liftIO . flip hPutStrLn s)++printLns :: [String] -> PrintM ()+printLns s = PrintM $ (ask >>= liftIO . flip hPutStr (unlines s))
+ Data/Cursor/CLASE/Gen/Util.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+module Data.Cursor.CLASE.Gen.Util where++import Control.Monad+import Data.Map (Map)+import Data.Maybe+import Language.Haskell.TH+import qualified Data.Map as Map++data DataType = DataType {+                  dtName :: Name,+                  dtCtrs :: [Constructor]+                }+              | WrapsList {+                  dtName :: Name,+                  dtConName :: Name,+                  dtChildName :: Name+                }++data Constructor = Ctr {+                     ctrName :: Name,+                     ctrKids :: [Child]+                   }++data Child +  = NonNavigable  { childType :: Name }+  | Navigable     { childType :: Name }++isWrapsList :: DataType -> Bool+isWrapsList (WrapsList _ _ _) = True+isWrapsList _ = False++constructors :: DataType -> [Constructor]+constructors d@(DataType {}) = dtCtrs d+constructors (WrapsList _ conName kidName) = [Ctr conName [Navigable kidName]]+++extractChildren :: DataType -> [Name]+extractChildren (DataType _ ctrs) = map ctrName ctrs+extractChildren (WrapsList _ cn _) = [cn]++isNavigable :: Child -> Bool+isNavigable (Navigable _) = True+isNavigable _ = False++buildMap :: [Name] -> Q (Map Name DataType)+buildMap okNames = do+  reifiedInfos <- mapM reify okNames+  let dts = map infoToDataType reifiedInfos +  return . Map.fromList . zip okNames $ dts+  where+    infoToDataType :: Info -> DataType+    infoToDataType info+      | isSoloCtr &&+        onlyOneTypeInCtr &&+        (extractTypeNoList soloType) `elem` okNames &&+        isList soloType     = WrapsList name soloCtrName soloNonListType+      | otherwise = DataType name (map mkCtr ctrs)+      where+        ctrs = extractConstructors info+        name = getInfoName info++        mkCtr :: Con -> Constructor+        mkCtr con = Ctr conName (map mkChild children)+          where+            children = extractChildTypesRaw $ con+            mkChild :: Type -> Child+            mkChild n+              | (extractTypeNoList n) `elem` okNames = Navigable (extractTypeNoList n)+              | otherwise = NonNavigable (extractType n)++            conName = getConName con++        isSoloCtr = length ctrs == 1+        headCtrsTypes = extractChildTypesRaw . head $ ctrs+        soloCtrName = getConName . head $ ctrs+        onlyOneTypeInCtr = length headCtrsTypes == 1+        soloType = head headCtrsTypes+        soloNonListType = extractTypeNoList soloType++data ContextCtr +  = ListCC {+    ctxCtrName :: String,+    ctxCtrTypeFrom :: Name,+    ctxCtrTypeTo :: Name,+    ctxCtrCtrTo :: Name+    }+  | NormalCC {+    ctxCtrName :: String,+    ctxCtrOffset_ :: Maybe Int,+    ctxCtrTypesBefore :: [Name],+    ctxCtrTypesAfter :: [Name],+    ctxCtrTypeFrom :: Name,+    ctxCtrTypeTo :: Name,+    ctxCtrCtrTo :: Name+    }+  deriving (Eq, Show)++numCCArgs :: ContextCtr -> Int+numCCArgs cc+  | ctxCtrIsList cc = 2 + val+  | otherwise = val+  where +    val = length (ctxCtrArgsBefore cc) + length (ctxCtrArgsAfter cc)+++downCtrName :: ContextCtr -> String+downCtrName cc = "M" ++ ctr ++ "To" ++ typ ++ moffset+  where+    ctr = nameBase . ctxCtrCtrTo $ cc+    typ = nameBase . ctxCtrTypeFrom $ cc+    moffset = maybe "" show . ctxCtrOffset $ cc++upCtrNameShown :: ContextCtr -> String+upCtrNameShown cc = mupctrshown+  where+    mupctrshown = "M" ++ typ ++ moffset ++ "To" ++ ctr++    ctr = nameBase . ctxCtrCtrTo $ cc+    typ = nameBase . ctxCtrTypeFrom $ cc+    moffset = maybe "" show . ctxCtrOffset $ cc++ctxCtrOffset :: ContextCtr -> Maybe Int+ctxCtrOffset (ListCC {}) = Nothing+ctxCtrOffset x = ctxCtrOffset_ x++ctxCtrIsList :: ContextCtr -> Bool+ctxCtrIsList (ListCC {}) = True+ctxCtrIsList _           = False++ctxCtrArgsBefore :: ContextCtr -> [String]+ctxCtrArgsBefore cc+  | ctxCtrIsList cc = []+  | otherwise = map nameBase . ctxCtrTypesBefore $ cc+  +ctxCtrArgsAfter :: ContextCtr -> [String]+ctxCtrArgsAfter cc+  | ctxCtrIsList cc = []+  | otherwise = map nameBase . ctxCtrTypesAfter $ cc++buildContextCtrs :: Map Name DataType -> [ContextCtr]+buildContextCtrs inMap = concatMap buildContextLines . Map.elems $ inMap+  where+    buildContextLines :: DataType -> [ContextCtr]+    buildContextLines (WrapsList dt cn ct) = [ListCC {+      ctxCtrName = (childName ++ "To" ++ conName),+      ctxCtrTypeFrom = ct,+      ctxCtrTypeTo   = dt,+      ctxCtrCtrTo    = cn+      }]+      where+        childName = nameBase ct+        conName   = nameBase cn+    buildContextLines (DataType dtName cons) = concatMap mkNormalCCs cons+      where+        mkNormalCCs :: Constructor -> [ContextCtr]+        mkNormalCCs (Ctr cn kids) = catMaybes $ mapWithContext kids maybeMkNormalCC+          where+            conName = nameBase cn++            maybeMkNormalCC :: [Child] -> Child -> [Child] -> Maybe ContextCtr+            maybeMkNormalCC _ (NonNavigable _) _ = Nothing+            maybeMkNormalCC before (Navigable n) after = Just $ NormalCC {+              ctxCtrName = (childName ++ "To" ++ conName ++ count),+              ctxCtrOffset_ = mcount,+              ctxCtrTypesBefore = map childType before,+              ctxCtrTypesAfter  = map childType after,+              ctxCtrTypeFrom    = n,+              ctxCtrTypeTo      = dtName,+              ctxCtrCtrTo       = cn+              }+              where+                childName = nameBase n+                count = maybe "" show mcount+                mcount+                  | null (sameSiblingsBefore ++ sameSiblingsAfter) = Nothing+                  | otherwise = Just . length $ sameSiblingsBefore+                  where+                    sameSiblingsBefore = filter ( (==n) . childType ) before+                    sameSiblingsAfter  = filter ( (==n) . childType ) after++mapWithContext :: [a] -> ([a] -> a -> [a] -> b) -> [b]+mapWithContext xs f = mapWithContext' xs f []+  where+    mapWithContext' [] _ _ = []+    mapWithContext' (x:xs) f r = (f r x xs):(mapWithContext' xs f (r ++ [x]))++extractConstructors :: Info -> [Con]+extractConstructors (TyConI dec) = getConstructors dec+extractConstructors _ = []++getConstructors :: Dec -> [Con]+getConstructors (DataD _ _ _ cons _)    = cons+getConstructors (NewtypeD _ _ _ con _)  = [con]+getConstructors _                       = []++getInfoName :: Info -> Name+getInfoName (TyConI (DataD _ n _ _ _))    = n+getInfoName (TyConI (NewtypeD _ n _ _ _)) = n+getInfoName x                    = error $ "Don't know how to get name for: " ++ show x++getConName :: Con -> Name+getConName (NormalC n _) = n+getConName (RecC n _)    = n+getConName x = error $ "GetConName: " ++ show x++extractChildTypesRaw :: Con -> [Type]+extractChildTypesRaw con = case con of+  (RecC _ types)    -> map thd $ types+  (NormalC _ types) -> map snd $ types+  _ -> []++extractTypeNoList :: Type -> Name+extractTypeNoList (ConT name) = name+extractTypeNoList (AppT (ConT lst) rhs)+  | lst == ''[] = (extractTypeNoList rhs)+extractTypeNoList x = error $ show x++isList :: Type -> Bool+isList (AppT (ConT lst) _) = lst == ''[]+isList _ = False++thd :: (a,b,c) -> c+thd (_,_,c) = c++extractType :: Type -> Name+extractType (ConT name) = name+extractType (AppT (ConT lst) rhs)+  | lst == ''[] = mkName $ "[" ++ nameBase (extractType rhs) ++ "]"+extractType x = error $ "Extract type; " ++ show x++extractChildTypes :: Con -> [Name]+extractChildTypes = catMaybes . map ect . extractChildTypesRaw +  where+    ect :: Type -> Maybe Name+    ect (ConT name) = Just name+    ect (AppT (ConT lst) rhs)+      | lst == ''[] = ect rhs+    ect _ = Nothing+
+ Data/Cursor/CLASE/Language.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs, +             ScopedTypeVariables,+             PatternSignatures,+             RankNTypes,+             MultiParamTypeClasses, NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+module Data.Cursor.CLASE.Language where++import Data.Cursor.CLASE.Util+import Data.Maybe+import Control.Monad++{- Directions -}+data Up+data Down++type family Invert d :: *++type instance Invert Up = Down+type instance Invert Down = Up++data DirectionT a where+  UpT   :: DirectionT Up+  DownT :: DirectionT Down+++{- Reify -} +class Reify l a where+  reify :: a -> TypeRep l a++data ExistsR l (r :: * -> *) where+  ExistsR :: (Reify l a) => r a -> ExistsR l r++{- Language -}+class Language l where+  data Context l :: * -> * -> *+  data Movement l :: * -> * -> * -> *+  data TypeRep l :: * -> *++  buildOne :: Context l a b -> a -> b++  unbuildOne :: Movement l Down a b -> a -> Maybe (Context l b a, b)++  invertMovement :: Movement l d a b -> Movement l (Invert d) b a+  +  movementEq :: Movement l d a b -> Movement l d a c -> Maybe (TyEq b c)++  reifyDirection :: Movement l d a b -> DirectionT d++  contextToMovement :: Context l a b -> Movement l Up a b++  +  downMoves :: TypeRep l a -> [ExistsR l (Movement l Down a)]+  moveLeft  :: Movement l Down a x -> Maybe (ExistsR l (Movement l Down a))+  moveRight :: Movement l Down a x -> Maybe (ExistsR l (Movement l Down a))+++contextMovementEq :: (Language l) => Context l a b -> Movement l Up a c -> Maybe (TyEq b c)+contextMovementEq context mov = (contextToMovement context) `movementEq` mov++{- Paths -}+infixr 5 `Step`++data Path l r a b where+  Stop :: Path l r a a+  Step :: (Reify l b) => r a b -> Path l r b c -> Path l r a c++foldPath :: (forall from to . (Reify l to) => r from to -> from -> to) -> start -> Path l r start finish -> finish+foldPath _ val Stop = val+foldPath step val (Step ng np) = foldPath step (step ng val) np +++{- Cursor -}+data Cursor l x a = (Reify l a) => Cursor { +    it :: a,+    ctx :: Path l (Context l) a l,+    log :: Route l a x+  }++data CursorWithMovement l d x from where+  CWM :: (Reify l to) => Cursor l x to -> Movement l d from to -> CursorWithMovement l d x from++rebuild :: (Language l) => Cursor l x a -> l+rebuild cursor = foldPath buildOne (it cursor) (ctx cursor) ++applyMovement :: (Language l, Reify l a, Reify l b) => +                 Movement l d a b -> Cursor l x a -> Maybe (Cursor l x b)+applyMovement mov (Cursor it ctx log) = case (reifyDirection mov) of+  UpT   -> case ctx of+    (Step up ups) -> case (up `contextMovementEq` mov) of+      Just Eq -> Just $ Cursor (buildOne up it) ups (updateRoute mov log)+      Nothing -> Nothing+    Stop -> Nothing+  DownT -> fmap (\(ctx', it') -> Cursor it' (Step ctx' ctx) (updateRoute mov log)) +                (unbuildOne mov it)++genericMoveUp :: (Language l) => Cursor l x a -> Maybe (CursorWithMovement l Up x a) +genericMoveUp (Cursor it (Step up ups) log) = Just $ CWM (Cursor (buildOne up it) ups (updateRoute upMov log)) upMov+  where+    upMov = contextToMovement up+genericMoveUp (Cursor _ Stop _) = Nothing++genericMoveDown :: (Language l) => Cursor l x a -> Maybe (CursorWithMovement l Down x a)+genericMoveDown cursor@Cursor {} = msum . map (\(ExistsR c) -> fmap (flip CWM c) . flip applyMovement cursor $ c) . downMoves . reify . it $ cursor++genericMoveLeft  :: (Language l) => Cursor l x a -> Maybe (ExistsR l (Cursor l x)) +genericMoveLeft = genericMoveSideways moveLeft ++genericMoveRight :: (Language l) => Cursor l x a -> Maybe (ExistsR l (Cursor l x)) +genericMoveRight = genericMoveSideways moveRight++genericMoveSideways :: forall l x a . (Language l) => +                       (forall a z . Movement l Down a z -> Maybe (ExistsR l (Movement l Down a))) -> Cursor l x a -> Maybe (ExistsR l (Cursor l x)) +genericMoveSideways fn cursor = do+  (CWM cursor' upmov ) <- genericMoveUp cursor+  let downmov = invertMovement upmov+  (ExistsR newDownMov) <- fn downmov+  cursor'' <- applyMovement newDownMov cursor'+  return $ ExistsR cursor''++moveToRoot :: (Language l) => Cursor l x a -> Cursor l x l+moveToRoot cursor@(Cursor _ Stop _)      = cursor+moveToRoot (Cursor it (Step up ups) log) = moveToRoot (Cursor (buildOne up it) ups (updateRoute (contextToMovement up) log))++{- Routes -}+data Route l from to where+  Route :: (Reify l mid) => Path l (Movement l Up) from mid ->+                            Path l (Movement l Down) mid to -> Route l from to +++route_invariant :: forall l from to . (Language l) => Route l from to -> Bool+route_invariant (Route (Step mup   Stop) +                       (Step mdown _)) = not . isJust $ res+  where+    mup' = invertMovement mup+    res = (mup' `movementEq` mdown)+route_invariant (Route (Step _ ups) downs) = route_invariant (Route ups downs)+route_invariant (Route Stop _) = True++updateRoute :: (Language l, +                Reify l a, +                Reify l b) => Movement l d a b -> Route l a c -> Route l b c+updateRoute mov route = case (reifyDirection mov) of+  UpT   -> case route of+    Route (Step up ups) downs -> case (mov `movementEq` up) of+      Just Eq -> Route ups downs+      Nothing -> error $ "Precondition violation: route up =/= movement up!"+    Route Stop steps -> Route Stop (Step (invertMovement mov) steps)+  DownT -> case route of+    Route Stop sdowns@(Step down downs) -> case (mov `movementEq` down) of+      Just Eq -> Route Stop downs+      Nothing -> Route (Step (invertMovement mov) Stop) sdowns+    Route ups downs -> Route (Step (invertMovement mov) ups) downs++resetLog :: Cursor l x a -> Cursor l a a+resetLog (Cursor it ctx _) = (Cursor it ctx (Route Stop Stop))++appendRoute :: (Language l, Reify l a, Reify l b, Reify l c) => +                Route l a b -> Route l b c -> Route l a c+appendRoute (Route Stop Stop) x = x+appendRoute (Route (Step up rst) y) r2 = updateRoute (invertMovement up)+                                                     (appendRoute (Route rst y) r2)+appendRoute (Route Stop (Step dwn rst)) r2 = updateRoute (invertMovement dwn) +                                                         (appendRoute (Route Stop rst) r2)++followRoute :: (Language l) => Cursor l x a -> Route l a c -> Maybe (Cursor l x c)+followRoute cursor (Route Stop Stop) = Just $ cursor+followRoute cursor@Cursor{} route@(Route (Step mup _) _)      = (applyMovement mup cursor)   >>= (\cursor'   -> followRoute cursor' (updateRoute mup route))+followRoute cursor@Cursor{} route@(Route Stop (Step mdown _)) = (applyMovement mdown cursor) >>= (\cursor' -> followRoute cursor' (updateRoute mdown route))
+ Data/Cursor/CLASE/Persistence.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+module Data.Cursor.CLASE.Persistence(+  showCursor,+  showRoute,+  parseCursor,+  parseRoute,+  Persistable(..),+  PersistenceAdapter(..),+  RestoredCursor(..),+  RestoredRoute(..),+  RestoredPath(..),+  readParser+) where++import Data.Cursor.CLASE.Language+import qualified Text.ParserCombinators.Parsec.Language as P+import qualified Text.ParserCombinators.Parsec.Token as P+import Text.ParserCombinators.Parsec+import Data.Cursor.CLASE.Util+import Control.Monad+import Control.Arrow++class (Language l, +       PersistenceAdapter l, +       Reify l l) => Persistable l where+  +  showMovement :: (Movement l d from to) -> String++  movementParser :: Reify l a => DirectionT d -> Parser ((ExistsR l (Movement l d a)))++  showTypeRep :: TypeRep l a -> String++  typeRepParser :: Parser (Exists (TypeRep l))++  typeRepEq :: TypeRep l a -> TypeRep l b -> Maybe (TyEq a b)+++class PersistenceAdapter l where+  showL :: l -> String+  parseL :: Parser l++data RestoredCursor l where+  RestoredCursor :: (Reify l x) => Cursor l x a -> RestoredCursor l++data RestoredRoute l from where+  RestoredRoute :: (Reify l to) => Route l from to -> RestoredRoute l from++data RestoredPath l r a where+  RestoredPath :: (Reify l b) => Path l r a b -> RestoredPath l r a++readParser :: (Show a, Read a) => Bool -> Parser a+readParser b+  | b = readParserP 11+  | otherwise = readParserP 0++readParserP :: (Show a, Read a) => Int -> Parser a +readParserP n = do+  cString <- getInput+  case readsPrec n cString of+    [(val, rest)] -> do+      setInput rest+      return val+    x -> error $ "readParser fail: " ++ show x ++ " - " ++ show cString++showCursor :: forall l x a . (Persistable l) => Cursor l x a -> String+showCursor cursor@(Cursor it _ log) = "Cursor { root = " ++ lS ++ ", " +++                                               "locationRep = " ++ itRepS ++ ", " ++ +                                               "location = " ++ locS ++ ", " +++                                               "log = " ++ logS ++ +                                               "}"+  where+    (Cursor root _ location) = moveToRoot $ resetLog cursor+    lS = showL root+    itRepS = showTypeRep ((reify it) :: TypeRep l a)+    locS = showRoute location+    logS = showRoute log+++showPath :: (Persistable l) => (forall a b . r a b -> Bool -> String) -> +                                          Path l r from to -> Bool -> String+showPath _ Stop _ = "Stop"+showPath contents (Step c nxt) b+  | b         = "(" ++ line ++ ")"+  | otherwise = line+  where+    line = "Step " ++ (contents c True) ++ " " ++ showPath contents nxt True ++showRoute :: (Persistable l) => Route l from to -> String+showRoute (Route mups mdowns) = "Route " ++ +                                showPath (const . showMovement) mups True ++ " " +++                                showPath (const . showMovement) mdowns True++parseCursor :: (Persistable l) => String -> Maybe (RestoredCursor l)+parseCursor = ((error . show) ||| Just) . parse cursorParser "" +-- TODO: error . show == Nothing++parseRoute :: (Persistable l, +               Reify l from) => Bool -> String -> Maybe (RestoredRoute l from)+parseRoute b = ((error . show) ||| Just) . parse (routeParser b) ""+-- TODO: error . show == Nothing++cursorParser :: forall l . (Persistable l) => Parser (RestoredCursor l)+cursorParser = do+  symbol "Cursor"+  braces $ do+    symbol "root" >> symbol "="+    (root :: l) <- parseL+    comma+    +    symbol "locationRep" >> symbol "="+    (Exists (itRep :: TypeRep l from)) <- (typeRepParser :: Parser (Exists (TypeRep l)))+    comma++    symbol "location" >> symbol "="+    (RestoredRoute (loc :: Route l l from')) <- (routeParser False :: Parser (RestoredRoute l l))+    (locFrom :: TypeRep l from') <- return (reify (undefined :: from'))+    (Just (Eq :: TyEq from from')) <- return (itRep `typeRepEq` locFrom)++    comma++    symbol "log" >> symbol "="+    (RestoredRoute (log :: Route l from x)) <- (routeParser False :: Parser (RestoredRoute l from))++    maybe (fail "Couldn't build cursor") (return . RestoredCursor) $ process root loc log+    where+      process :: l -> Route l l from -> Route l from x -> Maybe (Cursor l x from)+      process l loc log = do+        let cursorAtRoot = Cursor l Stop (Route Stop Stop)+        (Cursor endPos ctx _) <- followRoute cursorAtRoot loc+        return $ Cursor endPos ctx log++pathParser :: forall a r l . (Reify l a) => Bool -> (forall b . (Reify l b) => Parser ((ExistsR l (r b)))) -> Parser (RestoredPath l r a)+pathParser b cargoParser = (try stopParser) <|> (if' b parens id stepParser)+  where+    stopParser = symbol "Stop" >> return (RestoredPath Stop)+    stepParser = do+      symbol "Step"+      (ExistsR part) <- cargoParser+      (RestoredPath rest) <- pathParser True cargoParser +      return $ RestoredPath (Step part rest)++routeParser :: forall l a . (Persistable l, Reify l a) => Bool -> Parser (RestoredRoute l a)+routeParser b = (if' b parens id) $ do+  symbol "Route"+  (RestoredPath upMovs) <- pathParser True (movementParser UpT)+  (RestoredPath downMovs) <- pathParser True (movementParser DownT)++  let route = Route upMovs downMovs++  guard (route_invariant route)++  return $ RestoredRoute route+++haskellParser ::  P.TokenParser st+haskellParser = P.makeTokenParser P.haskellDef++symbol ::  String -> CharParser st String+symbol = P.symbol haskellParser+parens ::  CharParser st a -> CharParser st a+parens = P.parens haskellParser+braces ::  CharParser st a -> CharParser st a+braces = P.braces haskellParser+comma ::  CharParser st String+comma = P.comma haskellParser
+ Data/Cursor/CLASE/Traversal.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE RankNTypes, MultiParamTypeClasses, TypeFamilies, GADTs, RelaxedPolyRec, PatternSignatures, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+module Data.Cursor.CLASE.Traversal(+  Traversal(..),+  completeTraversal+) where++import Data.Cursor.CLASE.Bound+import Data.Cursor.CLASE.Language++class (Bound l t) => Traversal l t where++  visitStep :: (Reify l a) => a -> (forall b . Reify l b => Movement l Down a b -> t) -> t++  visitPartial :: Context l a b -> b -> t -> (forall c . Reify l c => Movement l Down b c -> t) -> t++  cursor :: l -> t -> t+++completeTraversal :: forall l t x a . (Traversal l t) => Cursor l x a -> t+completeTraversal (Cursor it ctx _) = foldUp (cursor (undefined :: l) (visitStep it hook')) it ctx+  where+    hook' :: forall b . Reify l b => Movement l Down a b -> t+    hook' = hook it++hook :: forall l t a b . (Traversal l t, Reify l b) => a -> Movement l Down a b -> t+hook here movement = case unbuildOne movement here of+  Just (ctx, b) -> let hook' :: forall c . Reify l c => Movement l Down b c -> t+                       hook' = hook b+                       in bindingHook ctx (visitStep b hook')+  Nothing -> error "Bad movement in traversal!"+++foldUp :: (Traversal l t) => t -> a -> Path l (Context l) a b -> t+foldUp t _ Stop = t+foldUp t here (Step ctx nxt) = foldUp (bindingHook ctx (visitPartial ctx next t (hook next))) next nxt+  where+    next = buildOne ctx here
+ Data/Cursor/CLASE/Util.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+module Data.Cursor.CLASE.Util where+++data Exists a where+  Exists :: a b -> Exists a++data TyEq a b where+  Eq :: TyEq a a++data Id a where+  Id :: a -> Id a++if' :: Bool -> a -> a -> a+if' b x y+  | b = x+  | otherwise = y
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Tristan Allwood++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain