diff --git a/CLASE.cabal b/CLASE.cabal
new file mode 100644
--- /dev/null
+++ b/CLASE.cabal
@@ -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: 
diff --git a/Data/Cursor/CLASE/Bound.hs b/Data/Cursor/CLASE/Bound.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Bound.hs
@@ -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
diff --git a/Data/Cursor/CLASE/Gen/Adapters.hs b/Data/Cursor/CLASE/Gen/Adapters.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Gen/Adapters.hs
@@ -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"
diff --git a/Data/Cursor/CLASE/Gen/Language.hs b/Data/Cursor/CLASE/Gen/Language.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Gen/Language.hs
@@ -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
diff --git a/Data/Cursor/CLASE/Gen/Persistence.hs b/Data/Cursor/CLASE/Gen/Persistence.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Gen/Persistence.hs
@@ -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"
+  ]
diff --git a/Data/Cursor/CLASE/Gen/PrintM.hs b/Data/Cursor/CLASE/Gen/PrintM.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Gen/PrintM.hs
@@ -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))
diff --git a/Data/Cursor/CLASE/Gen/Util.hs b/Data/Cursor/CLASE/Gen/Util.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Gen/Util.hs
@@ -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
+
diff --git a/Data/Cursor/CLASE/Language.hs b/Data/Cursor/CLASE/Language.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Language.hs
@@ -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))
diff --git a/Data/Cursor/CLASE/Persistence.hs b/Data/Cursor/CLASE/Persistence.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Persistence.hs
@@ -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
diff --git a/Data/Cursor/CLASE/Traversal.hs b/Data/Cursor/CLASE/Traversal.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Traversal.hs
@@ -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
diff --git a/Data/Cursor/CLASE/Util.hs b/Data/Cursor/CLASE/Util.hs
new file mode 100644
--- /dev/null
+++ b/Data/Cursor/CLASE/Util.hs
@@ -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
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain